#!/usr/bin/perl -w # author: mvc # $Id: biblio.pl,v 1.17 2007/08/24 22:31:35 root Exp root $ # aug-sep 2005: first version # apr 2006: multiple values for URLs, database_name; update of individual fields # may 2006: pubmed-style 'shopping cart' # fall 2006: slash->drupal conversion # aug 2007: generate list of database names automatically # Q: why are these all defined as function references? # A: because mod_perl requires it: # http://perl.apache.org/docs/general/perl_reference/perl_reference.html use strict; use CGI qw(escape unescape); CGI->compile(':standard'); use CGI::Carp qw(fatalsToBrowser warningsToBrowser); use DBI; use XML::Simple; use Data::Dumper; ############################ # global constants my $user; my $debug = 0; my $q = new CGI; my $tmpdir = '/tmp/'; my $op = $q->param('op') || ''; my $file = $q->param('file') || ''; my $f1 = $q->param('f1') || ''; my $v1 = $q->param('v1') || ''; my $f2 = $q->param('f2') || ''; my $v2 = $q->param('v2') || ''; my $k1 = $q->param('k1') || ''; my $db = $q->param('db') || 'A'; my $rd = $q->param('rd') || 'A'; my $gostart = $q->param('gostart') || '0'; my $go = $q->param('go') || ''; my $start = $q->param('start') || '0'; my $id = $q->param('id') || '0'; my @args = $q->param; my %save1 = $q->cookie('save1'); my %save2 = $q->cookie('save2'); my $per_page_default = 30; # these features are currently undocumented my $per_page = $q->param('display') || $per_page_default; my $show_abstracts = $q->param('show_abstracts') || 0; # security $gostart = abs int $gostart; $start = abs int $start; $per_page = abs int $per_page; $id = abs int $id; $go =~ s/[\W]+//g; $db =~ s/[\W]+//g; $rd =~ s/[\W]+//g; $f1 =~ s/[\W]+//g; $v1 =~ s/[^-\w \/?]+//g; $f2 =~ s/[\W]+//g; $v2 =~ s/[^-\w \/?]+//g; $k1 =~ s/[^-\w \/?\[\]()*',.&]+//g; # keywords have all these characters (sigh) my $fr_check_user = sub { # drupal authentication my $drupal_uid = CGI::cookie('drupal_uid'); my $drupal_admin = CGI::cookie('drupal_admin'); if ($drupal_uid && $drupal_uid > 0) { return 1; } else { return 0; } }; my $fr_check_admin = sub { # drupal authentication my $drupal_uid = CGI::cookie('drupal_uid'); my $drupal_admin = CGI::cookie('drupal_admin'); if ($drupal_admin && $drupal_admin eq 'true') { return 1; } else { return 0; } }; # generate this automatically, so RGP can upload new # files, corresponding to new database names # (NONE is only an option when applicable records exist) my %database_names = (); my %research_designs = ( "COM" , "Commentary", "DES" , "Descriptive", "MA" , "Meta-analysis", "PSY" , "Psychometric", "QE" , "Quasi experimental", "RCT" , "RCT", "REV" , "Review", "NONE", "Records with none specified", "A", "All Research Designs", ); my %research_design_descriptions = ( "COM" , "Commentaries provide opinions or reflections on other research or key issues.", "DES" , "Descriptive designs are those which use case studies, program descriptions and/or descriptive statistics.", "MA" , "Meta-analyses provide overviews of randomized control trials.", "PSY" , "Psychometric refers to designs focused on developing measures.", "QE" , "Quasi-experimental designs are those which use samples of convenience to test hypotheses.", "RCT" , "Randomised controlled trials (RCT) are designs which compare randomly selected groups.", "REV" , "Reviews provide overviews of research of all design types.", "NONE", "No research design available in summary.", ); my $dbh; my @db_fields = qw( rec_number ref_type_name ref_type_num database_path database_name title journal translated_title alt_title short_title orig_pub language authors secondary_authors pub_location auth_address work_type notes research_design pages volume number year pub_dates accession_num publisher isbn urls subset1 subset2 subset3 abstract ); my $sth_insert; my $sth_update; my %sth_update_fields; my %sth_fetch_fields; my $sth_keyword_check; my $sth_keyword_insert; my $sth_biblio_keyword_check; my $sth_biblio_keyword_insert; my $fr_db_init = sub { my $db_host = 'localhost'; my $db_user = 'rgp_biblio'; my $db_pass = 'rgp_biblio'; my $db_name = 'rgp_biblio'; my $db_uri = "dbi:mysql:dbname=${db_name};host=${db_host}"; $dbh = DBI->connect($db_uri, $db_user, $db_pass, { RaiseError => 1, AutoCommit => 0 }) || die "Error connecting to the database: $DBI::errstr\n"; unlink '/tmp/mvc2-dbi.log' if $debug > 1; $dbh->trace(1, '/tmp/mvc2-dbi.log') if $debug > 1; # set up database queries $sth_insert = $dbh->prepare(q{ INSERT INTO biblio ( rec_number, ref_type_name, ref_type_num, database_path, database_name, title, journal, translated_title, alt_title, short_title, orig_pub, language, authors, secondary_authors, pub_location, auth_address, work_type, notes, research_design, pages, volume, number, year, pub_dates, accession_num, publisher, isbn, urls, subset1, subset2, subset3, abstract ) VALUES ( ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ? ) }) || die $dbh->errstr; $sth_update = $dbh->prepare(q{ UPDATE biblio SET rec_number = ?, ref_type_name = ?, ref_type_num = ?, database_path = ?, database_name = ?, title = ?, journal = ?, translated_title = ?, alt_title = ?, short_title = ?, orig_pub = ?, language = ?, authors = ?, secondary_authors = ?, pub_location = ?, auth_address = ?, work_type = ?, notes = ?, research_design = ?, pages = ?, volume = ?, number = ?, year = ?, pub_dates = ?, accession_num = ?, publisher = ?, isbn = ?, urls = ?, subset1 = ?, subset2 = ?, subset3 = ?, abstract =? WHERE id=? }) || die $dbh->errstr; foreach my $db_field (@db_fields) { $sth_update_fields{$db_field} = $dbh->prepare(qq{UPDATE biblio SET $db_field = ? WHERE id = ?}) || die $dbh->errstr; } foreach my $db_field (@db_fields) { $sth_fetch_fields{$db_field} = $dbh->prepare(qq{SELECT $db_field FROM biblio WHERE id = ?}) || die $dbh->errstr; } $sth_keyword_check = $dbh->prepare(q{ SELECT kid FROM keywords WHERE keyword=?}) || die $dbh->errstr; $sth_keyword_insert = $dbh->prepare(q{ INSERT INTO keywords(keyword) VALUES (?)}) || die $dbh->errstr; $sth_biblio_keyword_check = $dbh->prepare(q{ SELECT id,kid FROM biblio_keywords WHERE id=? AND kid=?}) || die $dbh->errstr; $sth_biblio_keyword_insert = $dbh->prepare(q{ INSERT INTO biblio_keywords(id,kid) VALUES (?,?)}) || die $dbh->errstr; }; my $fr_normalize_research_design = sub { my $research_design = shift; $research_design = 'Descriptive' if $research_design eq 'Correlational'; $research_design = 'Psychometric' if $research_design eq 'Correlational - Factor analysis'; $research_design = 'Descriptive' if $research_design eq 'Correlational?'; $research_design = 'Quasi experimental' if $research_design eq 'Correlational? Experimental - Quasi?'; $research_design = 'Quasi experimental' if $research_design eq 'Correlational? Experimental - Sample as own control?'; $research_design = 'Quasi experimental' if $research_design eq 'Correlational? Experimental?'; $research_design = 'Descriptive' if $research_design eq 'Descriptive'; $research_design = 'Descriptive' if $research_design eq 'Descriptive - Case studies'; $research_design = 'Commentary' if $research_design eq 'Descriptive - Commentary/description'; $research_design = 'Commentary' if $research_design eq 'Descriptive - Commentary/description, Correlational?'; $research_design = 'Commentary' if $research_design eq 'Descriptive - Commentary/description, Meta-analysis?'; $research_design = 'Commentary' if $research_design eq 'Descriptive - Commentary/description?'; $research_design = 'Descriptive' if $research_design eq 'Descriptive - Qualitative'; $research_design = 'Descriptive' if $research_design eq 'Descriptive - Qualitiative'; $research_design = 'Descriptive' if $research_design eq 'Descriptive?'; $research_design = 'Descriptive' if $research_design eq 'Descriptive? Correlational?'; $research_design = 'Review' if $research_design eq 'Descriptive? Correlational? Meta-analysis?'; $research_design = 'Quasi experimental' if $research_design eq 'Descriptive? Experimental - Sample as own control/Quasi?'; $research_design = 'Descriptive' if $research_design eq 'Descriptive? Experimental?'; $research_design = 'Descriptive' if $research_design eq 'Descriptive? Meta-analysis?'; $research_design = 'Quasi Experimental' if $research_design eq 'Experimental'; $research_design = 'Quasi experimental' if $research_design eq 'Experimental - Quasi'; $research_design = 'Quasi experimental' if $research_design eq 'Experimental - Quasi?'; $research_design = 'RCT' if $research_design eq 'Experimental - RCT'; $research_design = 'RCT' if $research_design eq 'Experimental - RCT (baseline data)'; $research_design = 'Quasi experimental' if $research_design eq 'Experimental - Sample as own control'; $research_design = 'Quasi experimental' if $research_design eq 'Experimental - Sample as own control?'; $research_design = 'Quasi Experimental' if $research_design eq 'Experimental?'; $research_design = 'Meta-analysis' if $research_design eq 'Meta-analysis'; $research_design = 'Review' if $research_design eq 'Meta-analysis - Mixed?'; $research_design = 'Review' if $research_design eq 'Meta-analysis - Qualitative'; $research_design = 'Meta-analysis' if $research_design eq 'Meta-analysis - RCTs'; $research_design = 'Meta-analysis' if $research_design eq 'Metanalysis'; return $research_design; }; my $fr_fixup = sub { my $input = shift; return '' unless defined $input; $input =~ s/^\s*(.*?)\s*$/$1/; #return $dbh->quote($input); # done implicitly with variable substitution return $input; }; my $fr_fixup_byref = sub { my $input = shift; return '' unless defined $input; $$input =~ s/^\s*(.*?)\s*$/$1/; $$input = substr($$input, 0, 255) if length $$input > 255; # the VARCHAR type strips trailing spaces, so do this here too for # consistency when comparing strings $$input =~ s/ +$//; return $$input; }; my $fr_fixup_byref_full = sub { my $input = shift; return '' unless defined $input; $$input =~ s/^\s*(.*?)\s*$/$1/; return $$input; }; my $fr_joindata = sub { my $input = shift; $input =~ s/[\r\n]+/; /g; return $input; }; my $fr_print_record = sub { # this function is called 'print record' but it also prepares the # imported content to be inserted into the database. # # note that this deliberately uses defined instead of exists, so that # fr_add_record won't have to check for undefined hash values. this is # a tad messy but simpler to code than properly testing for existance # twice. as far as the database is concerned null values are # equivalent to empty strings, so this is okay. -- mvc my $record = shift; # print "
", Dumper($record), "
"; if (defined $record->{'rec-number'}->{content}) { printf "Record Number: %d
\n", &$fr_fixup_byref(\$record->{'rec-number'}->{content}); } if (defined $record->{'ref-type'}->{name}) { printf "Reference Type Name: %s
\n", &$fr_fixup_byref(\$record->{'ref-type'}->{name}); } if (defined $record->{'ref-type'}->{content}) { printf "Reference Type Number: %s
\n", &$fr_fixup_byref(\$record->{'ref-type'}->{content}); } if (defined $record->{database}->{path}) { printf "Database Path: %s
\n", &$fr_fixup_byref(\$record->{database}->{path}); } if (defined $record->{'remote-database-name'}->{style}->{content}) { printf "Database Name: %s
\n", &$fr_fixup_byref(\$record->{'remote-database-name'}->{style}->{content}); } if (defined $record->{titles}->{title}->{style}->{content}) { printf "Title: %s
\n", &$fr_fixup_byref(\$record->{titles}->{title}->{style}->{content}); } if (defined $record->{titles}->{'secondary-title'}->{style}->{content}) { printf "Secondary Title: %s
\n", &$fr_fixup_byref(\$record->{titles}->{'secondary-title'}->{style}->{content}); } if (defined $record->{titles}->{'translated-title'}->{style}->{content}) { printf "Translated Title: %s
\n", &$fr_fixup_byref(\$record->{titles}->{'translated-title'}->{style}->{content}); } if (defined $record->{titles}->{'short-title'}->{style}->{content}) { printf "Short Title: %s
\n", &$fr_fixup_byref(\$record->{titles}->{'short-title'}->{style}->{content}); } if (defined $record->{titles}->{'alt-title'}->{style}->{content}) { printf "Alternative Title: %s
\n", &$fr_fixup_byref(\$record->{titles}->{'alt-title'}->{style}->{content}); } if (defined $record->{'orig-pub'}->{style}->{content}) { printf "Original Publication: %s
\n", &$fr_fixup_byref(\$record->{'orig-pub'}->{style}->{content}); } if (defined $record->{language}->{style}->{content}) { printf "Language: %s
\n", &$fr_fixup_byref(\$record->{language}->{style}->{content}); } if (defined($record->{keywords}->{keyword})) { if (ref($record->{keywords}->{keyword}) eq 'ARRAY') { my @keywords; foreach my $keyword (@{$record->{keywords}->{keyword}}) { if (defined $keyword->{style}->{content}) { #printf "Keyword: %s
\n", $keyword->{style}->{content}; push @keywords, $keyword->{style}->{content}; &$fr_fixup_byref(\$keywords[$#keywords]); } } my $keywords = join('; ', @keywords); $record->{mykeywords} = $keywords; printf "Keyword%s: %s
\n", $#keywords > 0 ? 's' : '', $keywords; } else { my $keyword = $record->{keywords}->{keyword}; if (defined $keyword->{style}->{content}) { printf "Keyword: %s
\n", $keyword->{style}->{content}; $record->{mykeywords} = $keyword->{style}->{content}; $record->{mykeywords} =~ s/^\s*(.*?)\s*$/$1/; &$fr_fixup_byref(\$record->{mykeywords}); } } } if (defined($record->{contributors}->{authors}->{author})) { if (ref($record->{contributors}->{authors}->{author}) eq 'ARRAY') { my @authors; foreach my $author (@{$record->{contributors}->{authors}->{author}}) { if (defined $author->{style}->{content}) { #printf "Author: %s
\n", $author->{style}->{content}; push @authors, $author->{style}->{content}; &$fr_fixup_byref(\$authors[$#authors]); } } if ($#authors > 0) { my $temp = pop @authors; $authors[$#authors] .= ' and '.$temp; } my $authors = join(', ', @authors); $record->{contributors}->{myauthors} = join(', ', @authors); printf "Author%s: %s
\n", $authors[$#authors] =~ m/and/i ? 's' : '', $record->{contributors}->{myauthors}; } else { if (defined $record->{contributors}->{authors}->{author}->{style}->{content}) { my $authors = $record->{contributors}->{authors}->{author}->{style}->{content}; &$fr_fixup_byref(\$authors); #$authors =~ s/ (&|and) /, /; #$authors =~ s/([- .\w]+(,[- .\w]+)),/$1;/g; $authors =~ s/ et al\.$//; printf "Author%s: %s
\n", $authors =~ m/\b(&|and|et al)\b/i ? 's' : $authors =~ m/,.*,/ ? 's' : '', $authors; $record->{contributors}->{myauthors} = $authors; } } } if (defined($record->{contributors}->{'secondary-authors'}->{author})) { if (ref($record->{contributors}->{'secondary-authors'}->{author}) eq 'ARRAY') { my @authors; foreach my $author (@{$record->{contributors}->{'secondary-authors'}->{author}}) { if (defined $author->{style}->{content}) { push @authors, $author->{style}->{content}; &$fr_fixup_byref(\$authors[$#authors]); } } if ($#authors > 0) { my $temp = pop @authors; $authors[$#authors] .= ' and '.$temp; } my $authors = join(', ', @authors); $record->{contributors}->{myauthors2} = join(', ', @authors); printf "Author%s: %s
\n", $authors[$#authors] =~ m/and/i ? 's' : '', $record->{contributors}->{myauthors2}; } else { if (defined $record->{contributors}->{'secondary-authors'}->{author}->{style}->{content}) { my $authors = $record->{contributors}->{'secondary-authors'}->{author}->{style}->{content}; &$fr_fixup_byref(\$authors); #$authors =~ s/ (&|and) /, /; #$authors =~ s/([- .\w]+(,[- .\w]+)),/$1;/g; $authors =~ s/ et al\.$//; printf "Author%s: %s
\n", $authors =~ m/\b(&|and|et al)\b/i ? 's' : $authors =~ m/,.*,/ ? 's' : '', $authors; $record->{contributors}->{myauthors2} = $authors; } } } if (defined $record->{'pub-location'}->{style}->{content}) { printf "Publication Location: %s
\n", &$fr_fixup_byref(\$record->{'pub-location:'}->{style}->{content}); } if (defined $record->{'auth-address'}->{style}->{content}) { printf "Author Address: %s
\n", &$fr_fixup_byref(\$record->{'auth-address'}->{style}->{content}); } if (defined $record->{'work-type'}->{style}->{content}) { printf "Work Type: %s
\n", &$fr_fixup_byref(\$record->{'work-type'}->{style}->{content}); } if (defined $record->{notes}->{style}->{content}) { printf "Notes: %s
\n", &$fr_joindata( &$fr_fixup_byref(\$record->{notes}->{style}->{content})); } if (defined $record->{'research-notes'}->{style}->{content}) { $record->{'research-notes'}->{style}->{content} = &$fr_normalize_research_design( &$fr_fixup_byref(\$record->{'research-notes'}->{style}->{content})); printf "Research Design: %s
\n", $record->{'research-notes'}->{style}->{content}; } if (defined $record->{pages}->{style}->{content}) { printf "Pages: %s
\n", &$fr_fixup_byref(\$record->{pages}->{style}->{content}); } if (defined $record->{volume}->{style}->{content}) { printf "Volume: %s
\n", &$fr_fixup_byref(\$record->{volume}->{style}->{content}); } if (defined $record->{number}->{style}->{content}) { printf "Number: %s
\n", &$fr_fixup_byref(\$record->{number}->{style}->{content}); } if (defined $record->{dates}->{year}->{style}->{content}) { printf "Year: %s
\n", &$fr_fixup_byref(\$record->{dates}->{year}->{style}->{content}); } if (defined $record->{dates}->{'pub-dates'}->{date}->{style}->{content}) { printf "Publication Date: %s
\n", &$fr_fixup_byref( \$record->{dates}->{'pub-dates'}->{date}->{style}->{content}); } if (defined $record->{'accession-num'}->{style}->{content}) { printf "Accession Number: %s
\n", &$fr_fixup_byref(\$record->{'accession-num'}->{style}->{content}); } if (defined $record->{publisher}->{style}->{content}) { printf "Publisher: %s
\n", &$fr_fixup_byref(\$record->{publisher}->{style}->{content}); } if (defined $record->{isbn}->{style}->{content}) { printf "ISBN: %s
\n", &$fr_fixup_byref(\$record->{isbn}->{style}->{content}); } # 255 characters isn't enough for multiple URLs, so this is a TEXT column if (defined($record->{urls}->{'related-urls'}->{url})) { if (ref($record->{urls}->{'related-urls'}->{url}) eq 'ARRAY') { my @urls; foreach my $url (@{$record->{urls}->{'related-urls'}->{url}}) { if (defined $url->{style}->{content}) { next unless $url->{style}->{content} =~ m/http:\/\//; $url->{style}->{content} =~ s/.*(http:\/\/[^\s]+).*/$1/; printf qq(URL: %s
\n), $url->{style}->{content}, length $url->{style}->{content} > 80 ? substr($url->{style}->{content},0,80)."…" : $url->{style}->{content}; push @urls, $url->{style}->{content}; #$urls[$#urls] =~ s/^\s*(.*?)\s*$/$1/; #$urls[$#urls] =~ s/ /%20/g; #$urls[$#urls] =~ s/\s*//g; } } my $urls = join("\n", @urls); $record->{myurls} = $urls; } elsif (defined $record->{urls}->{'related-urls'}->{url}->{style}) { # this case is probably due to a data entry error if (ref($record->{urls}->{'related-urls'}->{url}->{style}) eq 'ARRAY') { my @urls; foreach my $url (@{$record->{urls}->{'related-urls'}->{url}->{style}}) { if (defined $url->{content}) { next unless $url->{content} =~ m/http:\/\//; $url->{style}->{content} =~ s/.*(http:\/\/[^\s]+).*/$1/; #$url->{style}->{content} = escape($url->{style}->{content}); printf qq(URL: %s
\n), $url->{content}, length $url->{content} > 80 ? substr($url->{content},0,80)."…" : $url->{content}; push @urls, $url->{content}; #$urls[$#urls] =~ s/^\s*(.*?)\s*$/$1/; #$urls[$#urls] =~ s/ /%20/g; #$urls[$#urls] =~ s/\s*//g; } } my $urls = join("\n", @urls); $record->{myurls} = $urls; print "(Possible data entry error for this URL; but it's been imported correctly anyways.)
\n"; } elsif (defined $record->{urls}->{'related-urls'}->{url}->{style}->{content}) { my $url = $record->{urls}->{'related-urls'}->{url}->{style}->{content}; if ($url =~ m/http:\/\//) { $url =~ s/.*(http:\/\/[^\s]+).*/$1/; #$url = escape($url); #$url =~ s/^\s*(.*?)\s*$/$1/; #$url =~ s/ /%20/g; #$url =~ s/\s*//g; $record->{myurls} = $url; printf qq(URL: %s
\n), $url, $url; } } } } if (defined $record->{custom1}->{style}->{content}) { printf "Subset #1: %s
\n", &$fr_fixup_byref(\$record->{custom1}->{style}->{content}); } if (defined $record->{custom2}->{style}->{content}) { printf "Subset #2: %s
\n", &$fr_fixup_byref(\$record->{custom2}->{style}->{content}); } if (defined $record->{custom3}->{style}->{content}) { printf "Subset #3: %s
\n", &$fr_fixup_byref(\$record->{custom3}->{style}->{content}); } if (defined $record->{abstract}->{style}->{content}) { printf "Abstract: %s
\n", &$fr_fixup_byref_full(\$record->{abstract}->{style}->{content}); } }; my $fr_add_record = sub { my $record = shift; my $sth_insert = shift; my $rv = $sth_insert->execute( $record->{'rec-number'}->{content} || '', $record->{'ref-type'}->{name} || '', $record->{'ref-type'}->{content} || '', $record->{database}->{path} || '', $record->{'remote-database-name'}->{style}->{content} || '', $record->{titles}->{title}->{style}->{content} || '', $record->{titles}->{'secondary-title'}->{style}->{content} || '', $record->{titles}->{'translated-title'}->{style}->{content} || '', $record->{titles}->{'alt-title'}->{style}->{content} || '', $record->{titles}->{'short-title'}->{style}->{content} || '', $record->{'orig-pub'}->{style}->{content} || '', $record->{language}->{style}->{content} || '', $record->{contributors}->{myauthors} || '', $record->{contributors}->{myauthors2} || '', $record->{'pub-location'}->{style}->{content} || '', $record->{'auth-address'}->{style}->{content} || '', $record->{'work-type'}->{style}->{content} || '', $record->{notes}->{style}->{content} || '', $record->{'research-notes'}->{style}->{content} || '', $record->{pages}->{style}->{content} || '', $record->{volume}->{style}->{content} || '', $record->{number}->{style}->{content} || '', $record->{dates}->{year}->{style}->{content} || '', $record->{dates}->{'pub-dates'}->{date}->{style}->{content} || '', $record->{'accession-num'}->{style}->{content} || '', $record->{publisher}->{style}->{content} || '', $record->{isbn}->{style}->{content} || '', $record->{myurls} || '', $record->{'custom1'}->{style}->{content} || '', $record->{'custom2'}->{style}->{content} || '', $record->{'custom3'}->{style}->{content} || '', $record->{abstract}->{style}->{content} || '' ) || die $dbh->errstr; return $dbh->{mysql_insertid}; }; my $fr_update_field = sub { my $datum = shift; my $field = shift; my $id = shift; my $sth_update_field = $sth_update_fields{$field}; return $sth_update_field->execute($datum, &$fr_fixup($id)) || die $dbh->errstr; }; my $fr_fetch_field = sub { my $field = shift; my $id = shift; my $sth_fetch_field = $sth_fetch_fields{$field}; $sth_fetch_field->execute(&$fr_fixup($id)) || die $dbh->errstr; my @result = $sth_fetch_field->fetchrow_array; return $result[0] if scalar @result; # for now a precondition of this function is that the record exist die $dbh->errstr; }; my $fr_check_field = sub { my $datum = shift; my $field = shift; my $id = shift; my $updated = shift; return unless $datum && $datum ne ''; my $old_datum = &$fr_fetch_field($field, $id); if (!defined $old_datum) { &$fr_update_field($datum, $field, $id); push @$updated, $field." (new)"; } elsif ($old_datum ne $datum) { &$fr_update_field($datum, $field, $id); push @$updated, $field; } }; # for these fields, allow multiple entries in the db my $fr_check_field2 = sub { my $datum = shift; my $field = shift; my $id = shift; my $updated = shift; return unless $datum && $datum ne ''; my $old_datum = &$fr_fetch_field($field, $id); if (!defined $old_datum) { &$fr_update_field($datum, $field, $id); push @$updated, $field." (new)"; } elsif ($old_datum ne $datum) { my @old_data = split /[\r\n]/, $old_datum; if (!scalar grep /^$datum$/, @old_data) { push @old_data, $datum; &$fr_update_field(join("\n", @old_data), $field, $id); push @$updated, $field." (additional value)"; } } }; # for these fields, allow multiple entries in the db & in the input XML file my $fr_check_field3 = sub { my $datum = shift; return unless $datum && $datum ne ''; my @data = split(/[\r\n]/, $datum); my $field = shift; my $id = shift; my $updated = shift; my $old_datum = &$fr_fetch_field($field, $id); if (!defined $old_datum) { &$fr_update_field($datum, $field, $id); push @$updated, $field." (new)"; } else { # for these fields, allow multiple entries my @old_data = split /[\r\n]/, $old_datum; my $new_data_count = 0; foreach my $datum (@data) { next unless $datum ne ''; if (!scalar grep(/^\Q$datum\E$/, @old_data)) { push @old_data, $datum; &$fr_update_field(join("\n", @old_data), $field, $id); $new_data_count++; } } if ($new_data_count > 1) { push @$updated, $field." ($new_data_count additional values)"; } elsif ($new_data_count > 0) { push @$updated, $field." (one additional value)"; } } }; my $fr_update_record = sub { my $record = shift; my $id = shift; my @updated; &$fr_check_field($record->{'rec-number'}->{content}, 'rec_number', $id, \@updated); &$fr_check_field($record->{'ref-type'}->{name}, 'ref_type_name', $id, \@updated); &$fr_check_field($record->{'ref-type'}->{content}, 'ref_type_num', $id, \@updated); &$fr_check_field($record->{database}->{path}, 'database_path', $id, \@updated); &$fr_check_field2($record->{'remote-database-name'}->{style}->{content}, 'database_name', $id, \@updated); &$fr_check_field($record->{titles}->{title}->{style}->{content}, 'title', $id, \@updated); &$fr_check_field($record->{titles}->{'secondary-title'}->{style}->{content}, 'journal', $id, \@updated); &$fr_check_field($record->{titles}->{'translated-title'}->{style}->{content}, 'translated_title', $id, \@updated); &$fr_check_field($record->{titles}->{'alt-title'}->{style}->{content}, 'alt_title', $id, \@updated); &$fr_check_field($record->{titles}->{'short-title'}->{style}->{content}, 'short_title', $id, \@updated); &$fr_check_field($record->{'orig-pub'}->{style}->{content}, 'orig_pub', $id, \@updated); &$fr_check_field($record->{language}->{style}->{content}, 'language', $id, \@updated); &$fr_check_field($record->{contributors}->{myauthors}, 'authors', $id, \@updated); &$fr_check_field($record->{contributors}->{myauthors2}, 'secondary_authors', $id, \@updated); &$fr_check_field($record->{'pub-location'}->{style}->{content}, 'pub_location', $id, \@updated); &$fr_check_field($record->{'auth-address'}->{style}->{content}, 'auth_address', $id, \@updated); &$fr_check_field($record->{'work-type'}->{style}->{content}, 'work_type', $id, \@updated); &$fr_check_field($record->{notes}->{style}->{content}, 'notes', $id, \@updated); &$fr_check_field($record->{'research-notes'}->{style}->{content}, 'research_design', $id, \@updated); &$fr_check_field($record->{pages}->{style}->{content}, 'pages', $id, \@updated); &$fr_check_field($record->{volume}->{style}->{content}, 'volume', $id, \@updated); &$fr_check_field($record->{number}->{style}->{content}, 'number', $id, \@updated); &$fr_check_field($record->{dates}->{year}->{style}->{content}, 'year', $id, \@updated); &$fr_check_field($record->{dates}->{'pub-dates'}->{date}->{style}->{content}, 'pub_dates', $id, \@updated); &$fr_check_field($record->{'accession-num'}->{style}->{content}, 'accession_num', $id, \@updated); &$fr_check_field($record->{publisher}->{style}->{content}, 'publisher', $id, \@updated); &$fr_check_field($record->{isbn}->{style}->{content}, 'isbn', $id, \@updated); &$fr_check_field3($record->{myurls}, 'urls', $id, \@updated); &$fr_check_field($record->{'custom1'}->{style}->{content}, 'subset1', $id, \@updated); &$fr_check_field($record->{'custom2'}->{style}->{content}, 'subset2', $id, \@updated); &$fr_check_field($record->{'custom3'}->{style}->{content}, 'subset3', $id, \@updated); &$fr_check_field($record->{abstract}->{style}->{content}, 'abstract', $id, \@updated); return [ @updated ]; }; my $fr_highlight = sub { my $text = shift || ''; my $terms = shift; my $entire_string = shift || 0; # optional return $text unless $terms; if (ref $terms eq "ARRAY") { foreach my $term (@$terms) { next unless $term ne ''; $entire_string ? $text =~ s/^\Q$term\E$/$&<\/span>/gi : $text =~ s/\Q$term\E/$&<\/span>/gi; } } else { $entire_string ? $text =~ s/^\Q$terms\E$/$&<\/span>/gi : $text =~ s/\Q$terms\E/$&<\/span>/gi; } return $text; }; my $fr_highlight_field = sub { # slightly tricky -- takes a list of search terms, which fields are # being searched, the name of the current field, a flag stating whether # the special field 'all of the above' includes the current field, an # optional flag stating whether the highlighting must match the entire # field text, plus the text of the field itself. a search term is only # highlighted if it was searched for on this particular field, so we # need to correlate the entries in the array of search terms and the # array of search fields, instead of highlighting every search word # regardless of where it appears. if we didn't check, users would be # confused about how the search logic works, so this needs to be the # same. my $this_field = shift; my $required_fields = shift; my $include_any = shift; my $text = shift || ''; my $terms = shift; my $entire_string = shift || 0; # optional return $text unless defined $this_field && defined $required_fields; if (ref $required_fields eq "ARRAY" && ref $terms eq "ARRAY") { return $text unless $#$required_fields == $#$terms; for (my $i=0;$i<=$#$required_fields;$i++) { my $required_field = $$required_fields[$i]; my $term = $$terms[$i]; next unless $required_field ne '' && $term ne ''; if ($this_field eq $required_field || ($include_any && $required_field eq 'any')) { $text = &$fr_highlight($text, $term, $entire_string); } } return $text; } else { if ($this_field eq $required_fields || ($include_any && $required_fields eq 'any')){ return &$fr_highlight($text, $terms, $entire_string); } else { return $text; } } }; my $fr_map_pubtype = sub { my $type = shift; return unless $type; return "Experimental, RCT" if $type eq "I"; return "Experimental, non-randomized" if $type eq "II-1"; return "Experimental, case control" if $type eq "II-2"; return "Experimental, quasi" if $type eq "II-3"; return "Descriptive" if $type eq "III"; return "Other"; }; my $fr_display_in_list_old = sub { my $list = shift || return; my $context = shift || ''; # sort by author name foreach my $id (sort {$list->{$a}->{authors} cmp $list->{$b}->{authors}} keys %$list) { my $record = $list->{$id}; $record->{title} .= "." unless $record->{title} =~ /[.?!]$/; $record->{authors} .= "." unless $record->{authors} =~ /[.?!]$/; printf qq(

Record %d (%s) %s%s

%s (%s) %s %s, %s(%s), %s.

\n), $id, &$fr_map_pubtype($record->{pubtype}), $context ? '' : '', &$fr_highlight_field('authors', $f1, 1, $record->{authors}, $v1), &$fr_highlight_field('year', $f1, 0, $record->{year}, $v1, 1), &$fr_highlight_field('title', $f1, 1, $record->{title}, $v1), &$fr_highlight_field('journal', $f1, 1, $record->{journal}, $v1), $record->{volume}, $record->{num}, $record->{page}; printf "

%s

\n", &$fr_highlight_field('abstract', $f1, 1, $record->{abstract}, $v1) if $record->{abstract}; } }; my $fr_display_in_list_new = sub { my $list = shift || return; my $context = shift || ''; # sort by author name here too foreach my $id (sort {$list->{$a}->{authors} cmp $list->{$b}->{authors}} keys %$list) { my $record = $list->{$id}; $record->{title} .= "." unless $record->{title} =~ /[.?!]$/; $record->{authors} .= "." unless $record->{authors} =~ /[.?!]$/; my $urls = ''; if ($record->{urls}) { foreach my $url (split (/[\r\n]+/, $record->{urls})) { my $url_disp = length $url > 80 ? substr($url,0,80)."…" : $url; $url_disp = $url if $context > 1; $urls .= qq(
Abstract URL: ). qq($url_disp); } } printf qq(

%sRecord #%d, ID #%d%s %s[more details]%s %s%s
%s (%s%s) %s %s, %s%s, %s. %s %s%s%s%s%s%s

\n), $context > 1 ? '': '', $context > 1 ? '': '', $context ? '' : '', &$fr_highlight_field('authors', [ $f1, $f2 ], 1, $record->{authors}, [ $v1, $v2 ] ), $record->{pub_dates} ? $record->{pub_dates}.', ' : '', &$fr_highlight_field('year', [ $f1, $f2 ], 0, $record->{year}, [ $v1, $v2 ] ), &$fr_highlight_field('title', [ $f1, $f2 ], 1, $record->{title}, [ $v1, $v2 ] ), &$fr_highlight_field('journal', [ $f1, $f2 ], 1, $record->{journal}, [ $v1, $v2 ] ), &$fr_highlight_field('volume', [ $f1, $f2 ], 0, $record->{volume}, [ $v1, $v2 ] ), $record->{number} ? '('. &$fr_highlight_field('number', [ $f1, $f2 ], 0, $record->{number}, [ $v1, $v2 ]) .')' : '', &$fr_highlight_field('pages', [ $f1, $f2 ], 0, $record->{pages}, [ $v1, $v2 ] ), $record->{auth_address} ? '' : '', $record->{database_name} ? sprintf '
Database Name: %s', &$fr_joindata($record->{database_name}) : '', $record->{research_design} ? sprintf '
Research Design: %s', &$fr_highlight_field('research_design', [ $f1, $f2 ], 1, $record->{research_design}, [ $v1, $v2 ]), : '', $record->{subset1} ? '
Subset #1: '.$record->{subset1}.'' : '', $record->{subset2} ? '
Subset #2: '.$record->{subset2}.'' : '', $record->{subset3} ? '
Subset #3: '.$record->{subset3}.'' : '', $urls; printf "

Abstract:
%s

\n", &$fr_highlight_field('abstract', [ $f1, $f2 ], 1, $record->{abstract}, [ $v1, $v2 ] ), if $record->{abstract} && $show_abstracts; ## print keywords #my @keywords; #$sth_keyword_biblio->execute($id); #while (my $row = $sth_keyword_biblio->fetch) { # $sth_keyword->execute($row->[0]); # while (my $row2 = $sth_keyword->fetch) { # push @keywords, &$fr_highlight($row2->[0], $k1, 1); # } #} #my $keywords = join '; ', sort @keywords; #print "

Keywords:
$keywords

" # if $keywords; } }; my $fr_list_new = sub { print $q->h2("List of Records"); print qq(
); printf qq(Clipboard: %d saved entr%s\n), $q->url(), scalar keys %save1, scalar keys %save1 == 1 ? 'y' : 'ies'; print qq([Help]\n); print qq(
); #print "

debug: cookie values

\n" if $debug; #print Data::Dumper->Dump([\%save1], [qw(*save1)]), "
\n" if $debug; # internally these indices are zero-based but we present them otherwise $start = $gostart if $start == 0 && $gostart > 0; $start-- if $start > 0; # the navigation bar at the top both displays the number of records and # allows users to search over various fields # # i admit this is a bit of a mess. -- mvc my $nav = sprintf '
', $q->url(); $nav .= ''; my $nav0 = qq(Database(s): |\n); $nav0 =~ s/value="$db"/value="$db" selected/; my $nav0a = qq(Research design(s): | \n); $nav0a =~ s/value="$rd"/value="$rd" selected/; $nav0 .= $nav0a; my $nav3 = qq( | Keyword: ); my $params = ''; if ($per_page != $per_page_default) { $params = "&per_page=$per_page"; print ""; } my $where = 'WHERE '; if ($v1) { # default field unless valid $f1 = 'title' unless $f1 eq 'abstract' or $f1 eq 'year' or $f1 eq 'authors' or $f1 eq 'notes' or $f1 eq 'journal' or $f1 eq 'any' or $f1 eq 'research_design' or $f1 eq 'volume' or $f1 eq 'subset1' or $f1 eq 'subset2' or $f1 eq 'subset3' or $f1 eq 'number' or $f1 eq 'pages'; # keep these search keys when forming links $params .= "&f1=$f1&v1=$v1"; # housekeeping $f1 = 'any' if $f1 eq 'any2'; if ($f1 eq 'any') { $where .= "title LIKE '%${v1}%' OR abstract LIKE '%${v1}%' OR authors LIKE '%${v1}%' OR notes LIKE '%${v1}%' OR research_design LIKE '%${v1}%' OR journal LIKE '%${v1}%'"; } elsif ( $f1 eq 'year' || $f1 eq 'volume' || $f1 eq 'number' || $f1 eq 'subset1' || $f1 eq 'subset2' || $f1 eq 'subset3' ) { $where .= "$f1 LIKE '${v1}'"; } else { $where .= "$f1 LIKE '%${v1}%'"; } } if ($v2) { $where .= $where eq "WHERE " ? "" : " AND "; # default field unless valid $f2 = 'title' unless $f2 eq 'abstract' or $f2 eq 'year' or $f2 eq 'authors' or $f2 eq 'notes' or $f2 eq 'journal' or $f2 eq 'any' or $f2 eq 'research_design' or $f2 eq 'volume' or $f2 eq 'subset1' or $f2 eq 'subset2' or $f2 eq 'subset3' or $f2 eq 'number' or $f2 eq 'pages'; # keep these search keys when forming links $params .= "&f2=$f2&v2=$v2"; # housekeeping $f2 = 'any' if $f2 eq 'any2'; if ($f2 eq 'any') { $where .= "title LIKE '%${v2}%' OR abstract LIKE '%${v2}%' OR authors LIKE '%${v2}%' OR notes LIKE '%${v2}%' OR research_design LIKE '%${v2}%' OR journal LIKE '%${v2}%'"; } elsif ( $f2 eq 'year' || $f2 eq 'volume' || $f2 eq 'number' || $f2 eq 'subset1' || $f2 eq 'subset2' || $f2 eq 'subset3' ) { $where .= "$f2 LIKE '${v2}'"; } else { $where .= "$f2 LIKE '%${v2}%'"; } } if ($db ne "A" && exists $database_names{$db}) { $where .= $where eq "WHERE " ? "" : " AND "; if ($db eq 'NONE') { $where .= "database_name = '' "; } else { $where .= "database_name LIKE '%$database_names{$db}%' "; } $params .= "&db=$db"; } if ($rd ne "A" && exists $research_designs{$rd}) { $where .= $where eq "WHERE " ? "" : " AND "; if ($rd eq 'NONE') { $where .= "research_design = '' "; } else { $where .= "research_design LIKE '$research_designs{$rd}' "; } $params .= "&rd=$rd"; } $where .= $where eq "WHERE " ? "1" : ""; # keywords are a special case my $list; my $num_recs; if ($k1) { $params .= "&k1=$k1"; my $q_k1 = $dbh->quote($k1); print "\n\n"; # this is ugly. it should be re-written with a proper INNER JOIN. # if this database gets larger someone will have to get around to # that to keep performance within reasonable limits. -- mvc # there's no other way to figure out how many records our query # matches. $list = $dbh->selectall_hashref("SELECT biblio.id FROM biblio, biblio_keywords, keywords $where AND keyword LIKE $q_k1 AND keywords.kid=biblio_keywords.kid AND biblio.id = biblio_keywords.id", "id") || die "Error connecting to the database: $DBI::errstr\n"; $num_recs = scalar keys %{$list}; $list = $dbh->selectall_hashref("SELECT biblio.id, keywords.kid, keyword, rec_number, ref_type_name, ref_type_num, database_path, database_name, title, journal, translated_title, alt_title, orig_pub, authors, secondary_authors, pub_location, auth_address, language, work_type, notes, research_design, pages, volume, number, year, pub_dates, accession_num, publisher, isbn, urls, subset1, subset2, subset3, abstract FROM biblio, biblio_keywords, keywords $where AND keyword LIKE $q_k1 AND keywords.kid=biblio_keywords.kid AND biblio.id = biblio_keywords.id ORDER BY authors LIMIT $start, $per_page", "id") || die "Error connecting to the database: $DBI::errstr\n"; } else { print "\n\n"; # there's no other way to figure out how many records our query # matches. $list = $dbh->selectall_hashref("SELECT id FROM biblio $where", "id") || die "Error connecting to the database: $DBI::errstr\n"; $num_recs = scalar keys %{$list}; $list = $dbh->selectall_hashref("SELECT id, rec_number, ref_type_name, ref_type_num, database_path, database_name, title, journal, translated_title, alt_title, orig_pub, authors, secondary_authors, pub_location, auth_address, language, work_type, notes, research_design, pages, volume, number, year, pub_dates, accession_num, publisher, isbn, urls, subset1, subset2, subset3, abstract FROM biblio $where ORDER BY authors LIMIT $start, $per_page", "id") || die "Error connecting to the database: $DBI::errstr\n"; } my $curr_recs = scalar keys %{$list}; my $end = $start + $per_page > $num_recs ? $num_recs : $start + $per_page; $end = $start + $curr_recs; $end = $start + 1 if $curr_recs == 0; my $nav1 = sprintf "Displaying %d of %d records from %d to %d\n", $curr_recs, $num_recs, $start+1, $end; # $nav1 .= sprintf ' | First %d', # $q->url(), "?op=list${params}", # $per_page # if $start > 0; # && $start > $per_page; $nav1 .= sprintf ' | ', $per_page if $start > 0; # $nav1 .= sprintf ' | Previous %d', # $q->url(), "?op=list${params}&start=", # $start - $per_page >= 0 ? $start - $per_page + 1 : 1, # $start < $per_page ? $per_page - $start : $per_page, # if $start > 0 && $curr_recs > 0 && $num_recs > $end && $start > $per_page; $nav1 .= sprintf ' | ', $start - $per_page >= 0 ? $start - $per_page + 1 : 1, $start < $per_page ? $per_page - $start : $per_page, if $start > 0 && $curr_recs > 0 && $num_recs >= $end && $start > $per_page; # $nav1 .= sprintf ' | Next %d', # $q->url(), "?op=list${params}&start=", $end + 1, # $per_page > $num_recs - $end ? $num_recs - $end : $per_page # if $num_recs - $end > 0; $nav1 .= sprintf ' | ', $end + 1, $per_page > $num_recs - $end ? $num_recs - $end : $per_page if $num_recs - $end > 0; $nav1 .= sprintf ' | Start display at: '. ' ', $start + 1 if $num_recs > $curr_recs; $nav1 .= " | "; my $nav2 = qq( Search: ); $nav2 =~ s/value="$f1"/value="$f1" selected/; $nav2 .= qq( = ); my $nav2a = qq( | ); $nav2a =~ s/value="$f2"/value="$f2" selected/; $nav2a .= qq( = ); $nav2 = $nav2 . $nav2a . $nav3. ''; my $allnav = "
". $nav. $nav1. "
". $nav0. $nav2. "
"; #"
"; print $allnav, "
"; my $sth_keyword_biblio = $dbh->prepare(q{ SELECT kid FROM biblio_keywords WHERE id=?}) || die $dbh->errstr; my $sth_keyword = $dbh->prepare(q{ SELECT keyword FROM keywords WHERE kid=? ORDER BY keyword}) || die $dbh->errstr; if ($curr_recs) { &$fr_display_in_list_new($list); } else { print "

No records selected!

\n"; } print "\n"; }; my $fr_clipboard_new = sub { print $q->h2("Clipboard"); print qq([back to previous page] ); #print "

debug: cookie values

\n" if $debug; #print Data::Dumper->Dump([\%save1], [qw(*save1)]), "
\n" if $debug; if (!scalar keys %save1) { print $q->h3("No saved records"); print $q->p("Please select some records first."); } else { printf qq([ printer-friendly version of this page ]\n), $q->url(); printf qq([clear clipboard]\n), $q->url(); my $where = "WHERE "; foreach my $saved_id (keys %save1) { $saved_id =~ s/s1_//; $where .= " OR id=$saved_id"; } $where =~ s/WHERE OR/WHERE /; print "\n\n\n"; my $list = $dbh->selectall_hashref("SELECT * FROM biblio $where ORDER BY authors", "id") || die "Error connecting to the database: $DBI::errstr\n"; &$fr_display_in_list_new($list, 1); } }; my $fr_clipboard_old = sub { print $q->h2("Clipboard (Old Records)"); print qq([back to previous page]); #print "

debug: cookie values

\n" if $debug; #print Data::Dumper->Dump([\%save2], [qw(*save2)]), "
\n" if $debug; if (!scalar keys %save2) { print $q->h3("No saved records"); print $q->p("Please select some records first."); } else { printf qq([ printer-friendly version of this page ]\n), $q->url(); printf qq([ clear clipboard ]\n), $q->url(); my $where = "WHERE "; foreach my $saved_id (keys %save2) { $saved_id =~ s/s2_//; $where .= " OR id=$saved_id"; } $where =~ s/WHERE OR/WHERE /; print "\n\n\n"; my $list = $dbh->selectall_hashref("SELECT * FROM biblio_old $where ORDER BY authors", "id") || die "Error connecting to the database: $DBI::errstr\n"; &$fr_display_in_list_old($list, 1); } }; my $fr_clipboard_new_print = sub { print $q->h2("Clipboard"); print qq([back to previous page]); if (!scalar keys %save1) { print $q->h3("No records saved"); print $q->p("Please select some records first."); return; } my $where = "WHERE "; foreach my $saved_id (keys %save1) { $saved_id =~ s/s1_//; $where .= " OR id=$saved_id"; } $where =~ s/WHERE OR/WHERE /; print "\n\n\n"; my $list = $dbh->selectall_hashref("SELECT * FROM biblio $where ORDER BY authors", "id") || die "Error connecting to the database: $DBI::errstr\n"; &$fr_display_in_list_new($list, 2); }; my $fr_clipboard_old_print = sub { print $q->h2("Clipboard (Old Records)"); print qq([back to previous page]); #print "

debug: cookie values

\n" if $debug; #print Data::Dumper->Dump([\%save2], [qw(*save2)]), "
\n" if $debug; if (!scalar keys %save2) { print $q->h3("No saved records"); print $q->p("Please select some records first."); return; } my $where = "WHERE "; foreach my $saved_id (keys %save2) { $saved_id =~ s/s2_//; $where .= " OR id=$saved_id"; } $where =~ s/WHERE OR/WHERE /; print "\n\n\n"; my $list = $dbh->selectall_hashref("SELECT * FROM biblio_old $where ORDER BY authors", "id") || die "Error connecting to the database: $DBI::errstr\n"; &$fr_display_in_list_old($list, 2); }; my $fr_list_old = sub { print $q->h2("Old Records"); print qq(
); printf qq(Clipboard: %d saved entr%s\n), $q->url(), scalar keys %save2, scalar keys %save2 == 1 ? 'y' : 'ies'; print qq([Help]\n); print qq(
); # internally these indices are zero-based but we present them otherwise $start = $gostart if $start == 0 && $gostart > 0; $start-- if $start > 0; printf '
', $q->url(); print ''; my $params = ''; if ($per_page != $per_page_default) { $params = "&per_page=$per_page"; print ""; } my $where = ''; if ($v1) { $f1 = 'any' if $f1 eq 'any2'; $f1 = 'title' unless $f1 eq 'abstract' or $f1 eq 'year' or $f1 eq 'authors' or $f1 eq 'journal' or $f1 eq 'any'; # keep these search keys $params .= "&f1=$f1&v1=$v1"; if ($f1 eq 'any') { $where = "WHERE title LIKE '%${v1}%' OR abstract LIKE '%${v1}%' OR authors LIKE '%${v1}%' OR journal LIKE '%${v1}%'"; } elsif ($f1 eq 'year') { $where = "WHERE $f1 = '${v1}'"; } else { $where = "WHERE $f1 LIKE '%${v1}%'"; } print ""; } my $list = $dbh->selectall_hashref("SELECT id FROM biblio_old $where", "id") || die "Error connecting to the database: $DBI::errstr\n"; my $num_recs = scalar keys %{$list}; $list = $dbh->selectall_hashref("SELECT * FROM biblio_old $where ORDER BY authors LIMIT $start, $per_page", "id") || die "Error connecting to the database: $DBI::errstr\n"; my $end = $start + $per_page > $num_recs ? $num_recs : $start + $per_page; my $curr_recs = scalar keys %{$list}; $end = $start + $curr_recs; if ($curr_recs == 0) { $end = $start + 1; } my $nav1 = sprintf "

Displaying %d of %d records from %d to %d \n", $curr_recs, $num_recs, $start+1, $end; #$nav1 .= sprintf ' | First %d', # $q->url(), "?op=list_old${params}", # $per_page # if $start > 0; $nav1 .= sprintf ' | ', $per_page if $start > 0; #$nav1 .= sprintf ' | Previous %d', # $q->url(), "?op=list_old${params}&start=", # $start - $per_page >= 0 ? $start - $per_page + 1 : 1, # $start < $per_page ? $per_page - $start : $per_page, # if $start > 0 && $curr_recs > 0 && $num_recs > $end # && $start > $per_page; $nav1 .= sprintf ' | ', $start - $per_page >= 0 ? $start - $per_page + 1 : 1, $start < $per_page ? $per_page - $start : $per_page, if $start > 0 && $curr_recs > 0 && $num_recs >= $end && $start > $per_page; #$nav1 .= sprintf ' | Next %d', # $q->url(), "?op=list_old${params}&start=", $end + 1, # $per_page > $num_recs - $end ? $num_recs - $end : $per_page # if $num_recs - $end > 0; $nav1 .= sprintf ' | ', $end + 1, $per_page > $num_recs - $end ? $num_recs - $end : $per_page if $num_recs - $end > 0; $nav1 .= sprintf qq( | Start display at: ), $start + 1 if $num_recs > $curr_recs; $nav1 .= " | "; # $nav1 .= sprintf "Search terms: %s matches # “%s”\n", $f1, $v1 if $v1; # $nav1 .= "

"; my $nav2 = qq(); $nav2 =~ s/value="$f1"/value="$f1" selected/; $nav2 .= qq( = ); $nav2 .= " "; print "
", $nav1, $nav2, "
"; if ($curr_recs) { &$fr_display_in_list_old($list); } else { print "

No records selected!

\n"; } print "\n"; }; my $fr_display = sub { # this shows all the information we have about the record, if the user # wants it print "

Record #$id

\n"; my $record = $dbh->selectrow_hashref("SELECT id, rec_number, ref_type_name, ref_type_num, database_path, database_name, title, journal, translated_title, alt_title, orig_pub, authors, secondary_authors, pub_location, auth_address, language, work_type, notes, research_design, pages, volume, number, year, pub_dates, accession_num, publisher, isbn, urls, subset1, subset2, subset3, abstract, modified FROM biblio WHERE id=$id LIMIT 1"); if (!$record) { print "No such record #$id. Please try again.
\n"; return; } printf qq([ save to clipboard ]
\n), $q->url(), $id, $id; $record->{title} .= "." unless $record->{title} =~ /[.?!]$/; $record->{authors} .= "." unless $record->{authors} =~ /[.?!]$/; printf "

Record #%d, ID #%d (publication type: %s)
%s (%s%s) %s %s, %s%s, %s.

\n", $record->{rec_number}, $id, $record->{ref_type_name}, $record->{authors}, $record->{pub_dates} ? $record->{pub_dates}.', ' : '', $record->{year}, $record->{title}, $record->{journal}, $record->{volume}, $record->{number} ? '('.$record->{number}.')' : '', $record->{pages}; printf 'Secondary Author(s): %s
', $record->{secondary_authors} if $record->{secondary_authors}; printf 'Translated Title: %s
', $record->{translated_title} if $record->{translated_title}; printf 'Alternate Title: %s
', $record->{alt_title} if $record->{alt_title}; printf 'Originally Published As: %s
', $record->{orig_pub} if $record->{orig_pub}; printf 'Language: %s
', $record->{language} if $record->{language}; printf 'ISBN: %s
', $record->{isbn} if $record->{isbn}; printf 'Work Type: %s
', $record->{work_type} if $record->{work_type}; printf 'Database Name: %s
', &$fr_joindata($record->{database_name}) if $record->{database_name}; printf 'Research Design: %s
', $record->{research_design} if $record->{research_design}; print 'Address: '. $record->{auth_address}.'
' if $record->{auth_address}; if ($record->{urls}) { foreach my $url (split (/[\r\n]+/, $record->{urls})) { my $url_disp = length $url > 80 ? substr($url,0,80)."…" : $url; print qq(Abstract URL: ). qq($url_disp
); } } print '

'; print 'Subset #1: '. $record->{subset1}.'
' if $record->{subset1}; print 'Subset #2: '. $record->{subset2}.'
' if $record->{subset2}; print 'Subset #3: '. $record->{subset3}.'
' if $record->{subset3}; printf "

Notes:
%s

\n", &$fr_joindata($record->{notes}) if $record->{notes}; printf "

Abstract:
%s

\n", $record->{abstract} if $record->{abstract} && $show_abstracts; # print keywords my @keywords; my $sth_keyword_biblio = $dbh->prepare(q{ SELECT kid FROM biblio_keywords WHERE id=?}) || die $dbh->errstr; my $sth_keyword = $dbh->prepare(q{ SELECT keyword FROM keywords WHERE kid=? ORDER BY keyword}) || die $dbh->errstr; $sth_keyword_biblio->execute($id); while (my $row = $sth_keyword_biblio->fetch) { $sth_keyword->execute($row->[0]); while (my $row2 = $sth_keyword->fetch) { push @keywords, &$fr_highlight($row2->[0], $k1, 1); } } my $keywords = join '; ', sort @keywords; print "

Keywords:
$keywords

" if $keywords; print "

Record last updated: $record->{modified}

"; }; my $fr_search_new = sub { # the same search interface is available from the main record listing, # but it's here in case that's too cryptic for some users printf qq(

Search New Records

Where matches:
and matches:
with the following keywords: ), $q->url(); print qq(
from the following database: \n); print qq(
with the following research designs: \n); print qq(

\n); }; my $fr_search_old = sub { # the same search interface is available from the main record listing, # but it's here in case that's too cryptic for some users printf '

Search Old Records

Search for records in which: matches

', $q->url(); }; my $fr_upload = sub { # first, let's be paranoid about security and other possible problems if (!defined($file) || $file eq '') { print $q->h3("Error: no file name given"); return; } if ($file !~ m/^[-\w .]+$/) { print $q->h3("Error: invalid characters in given file name"); print $q->p("Please rename the file and try again."); return; } if (! -e $tmpdir.$file) { print $q->h3("Error: no such file '$file'"); return; } if (! -r $tmpdir.$file) { print $q->h3("Error: file '$file' not readable"); return; } # alright, now we can import the XML file my $xs1 = XML::Simple->new(); my $doc = $xs1->XMLin($tmpdir.$file, ForceContent => 1); my $num_records_added = 0; my $num_records_updated = 0; my $num_keywords_added = 0; # return the keyword id, or 0 if not already added my $fr_check_keyword = sub { my $keyword = shift; my $sth_keyword_check = shift; $sth_keyword_check->execute($keyword); if ($sth_keyword_check->rows > 0) { my $result = $sth_keyword_check->fetchrow_hashref; return $result->{kid}; } else { return 0; } }; my $fr_process_record = sub { my $record = shift; # check if this record's already in the database, which we do by # checking the endnotes database filename (without the path), and # the endnotes record number within that file. hopefully this is # a unique identifier. #if (!(defined $record->{'rec-number'}->{content} && # defined $record->{database}->{path})) { # print "Warning: no record number or database source # given for this entry!
\n"; # print "Skipping because we can't test if it's already # been upload...\n"; #} else { #my $path = $record->{database}->{path}; #$path =~ s/.*[\/\\]//; #$path = $dbh->quote($path); #$path =~ s/^'/'%/; #my $query = sprintf "SELECT id, rec_number, modified, # database_path FROM biblio where rec_number=%d AND # database_path LIKE %s", # $record->{'rec-number'}->{content}, $path; #my $ref = $dbh->selectrow_hashref($query); my $id; #if (defined $ref) { # $path =~ s/%//; # printf "Already in database! (id=%d) # (database=%s) (date added=%s)
\n", # $ref->{id}, $path, $ref->{modified}; # print "To add this record anyways, please upload it # using a different record number or Endnotes file # name.
\n"; # $id = $ref->{id}; #} else { my $query2 = sprintf "SELECT id, title, journal, volume, number, year, pages, rec_number, modified, database_path FROM biblio WHERE title LIKE %s AND journal LIKE %s AND volume LIKE %s AND number LIKE %s AND year=%d", $dbh->quote($record->{titles}->{title}->{style}->{content} || ''), $dbh->quote($record->{titles}->{'secondary-title'}->{style}->{content} || ''), $dbh->quote($record->{volume}->{style}->{content} || ''), $dbh->quote($record->{number}->{style}->{content} || ''), $record->{dates}->{year}->{style}->{content} || 0; my $ref2 = $dbh->selectrow_hashref($query2); print "\n"; if (defined $ref2) { printf "Already in database! (id=%d) (database=%s) (date added=%s)
\n", $ref2->{id}, $ref2->{database_path}, $ref2->{modified}; print "A record already exists with the same title, journal name, volume, and number. It will be updated with these new data and keywords.
\n"; $id = $ref2->{id}; my $updated = &$fr_update_record($record, $id); if (scalar @$updated) { print "(Fields updated were: ", join('; ',@$updated), ")
\n"; $num_records_updated++; } else { print "(No fields updated.)
\n"; } } else { # new record $id = &$fr_add_record($record, $sth_insert); printf "Added to database (id=%d)
\n", $id; $num_records_added++; } #} # handle this separately so that people can add new keywords # more easily. they can upload the same file with only the # keywords changed, and it will work. if (exists $record->{mykeywords}) { my @keywords = split(/; /, $record->{mykeywords}); foreach my $keyword (@keywords) { # make sure keywords are in database; get kid my $kid = &$fr_check_keyword($keyword, $sth_keyword_check); if ($kid == 0) { $sth_keyword_insert->execute($keyword); $kid = $dbh->{mysql_insertid}; $num_keywords_added++; } # add association between this keyword and this record, # if not already there $sth_biblio_keyword_check->execute($id,$kid); if (!$sth_biblio_keyword_check->rows) { $sth_biblio_keyword_insert->execute($id,$kid); } } } #} }; print $q->h3("Parsing file..."); if (ref $doc->{records}->{record} eq "ARRAY") { for (my $i=0;$i<=$#{$doc->{records}->{record}};$i++) { print "
\n"; my $record = $doc->{records}->{record}[$i]; &$fr_print_record($record); # print and pre-process record &$fr_process_record($record); # add it, plus its keywords } } else { # just one record in XML file print "
\n"; my $record = $doc->{records}->{record}; &$fr_print_record($record); &$fr_process_record($record); } $dbh->commit or die $dbh->errstr; # success -- delete file #unlink $tmpdir.$file; my $url = $q->url(); print qq(

Imported $num_records_added new records; $num_keywords_added new keywords; $num_records_updated updates to existing records

Go to list of current records or upload another file

); }; my $fr_upload_form = sub { # # i couldn't get this file upload to work in perl. i spent all # afternoon on it and i have no idea what was wrong. while i'm sure it # could have been resolved it was faster to write this one part in PHP. # i blame mod_perl. -- mvc # print << 'EOF';

XML file upload

Upload an XML file exported from Endnotes here.



Please note: the software currently supports only the “Journal Article” entry type, and only the following data fields:
  • abstract
  • accession-num
  • alt-title
  • auth-address
  • author
  • authors
  • contributors
  • custom1
  • custom2
  • custom3
  • database
  • date
  • dates
  • isbn
  • keyword
  • keywords
  • language
  • notes
  • number
  • orig-pub
  • pages
  • pub-dates
  • publisher
  • pub-location
  • rec-number
  • ref-type
  • related-urls
  • remote-database-name
  • research-notes
  • secondary-authors
  • secondary-title
  • short-title
  • source-app
  • style
  • title
  • titles
  • translated-title
  • url
  • urls
  • volume
  • work-type
  • year

EOF #
# #
Input file: # # #
#
}; my $fr_show_homepage = sub { open(INCLUDE,") { print $block; } close(INCLUDE); }; my $fr_show_links = sub { my $url = $q->url(); print qq(

List current records | List old records
Search current records | Search old records

); print qq(
Administrators Only: Upload file
) if &$fr_check_admin(); }; my $fr_show_signup = sub { my $url = $q->url(); print qq(

This service is only available to registered users. Please sign in or apply for an account here.

); }; my $fr_cleanup = sub { $dbh->trace(0) if $debug > 1; $dbh->disconnect || die "Error connecting to the database: $DBI::errstr\n"; }; my $fr_myfooter = sub { #my $url = $q->url(); #print "
\n" unless $op =~ /print/; #print qq([ RGP Reference Manager Start Page ]); #print $q->end_html; if ($op !~ /print/) { open(TAIL,") { print $block; } close(TAIL); } }; my $fr_clear_new = sub { print $q->h2("Clipboard"); #print "

debug: cookie values

\n" if $debug; #print Data::Dumper->Dump([\%save1], [qw(*save1)]), "
\n" if $debug; print $q->p(qq(The clipboard has been cleared.)); }; my $fr_clear_old = sub { print $q->h2("Clipboard (Old Records)"); #print "

debug: cookie values

\n" if $debug; #print Data::Dumper->Dump([\%save2], [qw(*save2)]), "
\n" if $debug; print $q->p(qq(The clipboard has been cleared.)); }; my $fr_myheader = sub { my $op = shift || ''; # set cookies foreach my $save (grep /^s1_\d+$/, @args) { $save1{$save} = 'y'; } foreach my $save (grep /^s2_\d+$/, @args) { $save2{$save} = 'y'; } %save1 = () if $op eq 'clear'; %save2 = () if $op eq 'clear_old'; my $cookie_save1 = $q->cookie(-name=>'save1', -value=>\%save1); my $cookie_save2 = $q->cookie(-name=>'save2', -value=>\%save2); # so that the count of clipboard entries is up to date print $q->header(-cookie=>[$cookie_save1,$cookie_save2], -expires=>'-1d'); #print $q->start_html(-title=>'RGP Reference Manager', # -style=>{'src'=>'/biblio/biblio.css'}, # -lang=>'en-CA'); # # # print << 'EOF' ; RGP Reference Manager EOF if ($op !~ /print/) { open(HEAD,") { print $block; } close(HEAD); } }; # generate list of all db names my $fr_db_list = sub { my %db_list; my $dbs = $dbh->selectall_arrayref("SELECT DISTINCT(database_name) FROM biblio") || die "Error connecting to the database: $DBI::errstr\n"; # this field contains strings separated by newlines foreach my $db (@$dbs) { foreach my $db2 (@$db) { my @dbs2 = split /[\n\r]/, $db2; foreach my $db3 (@dbs2) { # normalize case $db3 = lc $db3; $db3 =~ s/\b[a-z]/\U$&/g; $db3 =~ s/\b(And|Of|For|The|A)\b/\l$&/g; $db_list{$db3} = 1; } } } my @db_list = sort keys %db_list; %db_list = (); for (my $i=0; $i <= $#db_list; $i++) { my $key = sprintf("DB%02d", $i); $db_list{$key} = $db_list[$i]; } $db_list{'A'} = 'All Databases'; # check for records with no db specified my $list = $dbh->selectall_hashref("SELECT database_name FROM biblio WHERE database_name = ''", "database_name") || die "Error connecting to the database: $DBI::errstr\n"; my $num_recs = scalar keys %{$list}; $db_list{'NONE'} = 'Records with none specified' if $num_recs; %database_names = %db_list; }; # main() &$fr_myheader($op); if (&$fr_check_user()) { &$fr_db_init(); &$fr_db_list(); if ($op eq 'upload' && &$fr_check_admin()) { &$fr_upload(); } elsif ($op eq 'upload_form' && &$fr_check_admin()) { &$fr_upload_form(); } elsif ($op eq 'list') { &$fr_list_new(); } elsif ($op eq 'search') { &$fr_search_new(); } elsif ($op eq 'list_old') { &$fr_list_old(); } elsif ($op eq 'search_old') { &$fr_search_old(); } elsif ($op eq 'clipboard') { &$fr_clipboard_new(); } elsif ($op eq 'clipboard_old') { &$fr_clipboard_old(); } elsif ($op eq 'clipboard_print') { &$fr_clipboard_new_print(); } elsif ($op eq 'clipboard_old_print') { &$fr_clipboard_old_print(); } elsif ($op eq 'clear') { &$fr_clear_new(); } elsif ($op eq 'clear_old') { &$fr_clear_old(); } elsif ($op eq 'display') { &$fr_display(); } else { &$fr_show_links(); &$fr_show_homepage(); } &$fr_cleanup(); } else { &$fr_show_signup(); &$fr_show_homepage(); } &$fr_myfooter($op);