#!/usr/bin/perl package dictyBaseCentralModTest; # Author: Shuai Weng # Date: June 2000 # Revision: May 2001, K. Tse # Description: This package contains reusable modules for dictyBase # projects. # use strict; use DBI; use CGI qw/:standard :html3/; use lib "/usr/local/dicty/www_dictybase/db/lib/common"; use Login qw (ConnectToDatabase); use lib "/usr/local/dicty/www_dictybase/db/lib/dictyBase"; use FormatdictyBase qw (PrintPageTop PrintSmallLogoPageTop Divider75 FooterReturnEmail); use lib "/usr/local/dicty/www_dictybase/db/lib/dictyBase/Objects"; use ConfigURLdictyBase; use ConfigPathdictyBase; use Exporter(); use vars qw ($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS); $VERSION = 1.00; @ISA = qw( Exporter ); %EXPORT_TAGS = ( formatPage=> [qw/printStartPage printShowInfoBox printSmallStartPage printEndPage ResultPageList ResultNumber subtitle returnToCuratorCentral/], navigateInfo=> [qw/navigationBar/], getInfo=> [qw/getUsernamePassword getColleagueNoBYlname getColleagueNoBYlocus getColleagueNoBYaceNm getColleagueNoBYfullname getColleagueNoBYname getFeatureNoBYfeatureNm getFeatureNmBYfeatureNo getLocusNmBYfeatureNo getLocusNmBYlocusNo getLocusNoBYlocusNm getFeatureNmBYlocusNo getRefNoCitationlistFromRefLink getLocusArrayRefBYgpNo getLocusArrayRefBYgoid getFeatureArrayRefBYgoid getCDKeywords/], logInfo=> [qw/updateDeleteLog updateUpdateLog/], insertInfo=>[qw/insertRefLink insertLocusGeneInfo insertFeatGeneInfo/] ); # add all subs in getInfo and other tags to @EXPORT_OK Exporter::export_ok_tags('formatPage'); Exporter::export_ok_tags('navigateInfo'); Exporter::export_ok_tags('getInfo'); Exporter::export_ok_tags('logInfo'); Exporter::export_ok_tags('insertInfo'); ######################################################################## sub printStartPage { ######################################################################## my ($database, $title, $help, $help2) = @_; print header; ###################### my $JSCRIPT=<"); myWin.document.close(); } END ####################### my $headerTitle = $title; $headerTitle =~ s/^(.*)]+>([^<]+)<\/A>(.*)$/$1$2$3/i; $headerTitle =~ s/^(.*)([^<]+)<\/i>(.*)$/$1$2$3/i; print start_html(-'title'=>$headerTitle, -'script'=>$JSCRIPT); print "\n"; &PrintPageTop($database, $title, $help, $help2); } ######################################################################## sub printShowInfoBox { ######################################################################## my ($text) = @_; print center(start_form(-name=>'infoform'). textfield(-name=>'info', -size=>'90', -value=>$text). end_form),"\n"; } ######################################################################## sub printSmallStartPage { ######################################################################## my ($database, $title, $help) = @_; print header; print start_html(-'title'=>$title); &PrintSmallLogoPageTop($database, $title, $help); print &Divider75; } ######################################################################## sub printEndPage { ######################################################################## print &Divider75, &FooterReturnEmail, end_html; } ###################################################################### sub subtitle { ###################################################################### my($subtitle) = @_; return table({-border=>'0', -cellpadding=>'4', -cellspacing=>'3', -width=>'650'}, Tr(td({-width=>'100%', -bgcolor=>'#a4abc2'}, font({-size=>'+2'}, b($subtitle))))); } ###################################################################### sub returnToCuratorCentral { ###################################################################### my ($user, $url) = @_; print start_form(-action=>"$url", -method=>"post"), hidden(-name=>'return', -value=>'curator'), hidden(-name=>'user', -value=>"$user"), submit(-name=>'Submit', -value=>'Go back to list of entries'), endform; } ###################################################################### sub navigationBar { ###################################################################### my (%args) = @_; my $database = $args{'database'}; my $url = $args{'url'}; my $nextPrevUrl = defined($args{'nextPrevUrl'}) ? $args{'nextPrevUrl'} : $url; my $beg = defined($args{'beg'}) ? $args{'beg'} : '1'; my $next = $args{'nextBeg'}; my $prev = $args{'prevBeg'}; my $downloadfile = $args{'downloadfile'}; my $navigateListRef = $args{'navigateListRef'}; my $sortListRef = $args{'sortListRef'}; my $pos = defined($args{'pos'}) ? $args{'pos'} : 'bot'; my ($downloadUrl, $barColor); my $configUrl = ConfigURLdictyBase->new; if ($database =~ /(dictyBase|sdev)/i) { $barColor= "#a4abc2"; if ($downloadfile) { $downloadUrl = $configUrl->dictyBaseHtmlTmp."$downloadfile"; } } my $topGif = $configUrl->dictyBaseImages."top.gif"; my $botGif = $configUrl->dictyBaseImages."bot.gif"; my $nextpgGif = $configUrl->dictyBaseImages."nextpg.gif"; my $prevpgGif = $configUrl->dictyBaseImages."prevpg.gif"; my $pageNavigation = td({-align=>'center'}, a({-href=>"#top"}, img({-src=>"$topGif", -width=>'39', -height=>'26', -border=>'0'})).br. a({-href=>"#bot"}, img({-src=>"$botGif", -width=>'39', -height=>'24', -border=>'0'}))); my $colspan = 1; if ($prev) { $colspan++; $pageNavigation = td({-align=>'center'}, a({-href=>"$nextPrevUrl&beg=$prev"}, img({-src=>"$prevpgGif", -width=>'39', -height=>'50', -border=>'0'})) ).$pageNavigation; } if ($next) { $colspan++; $pageNavigation .= td({-align=>'center'}, a({-href=>"$nextPrevUrl&beg=$next"}, img({-src=>"$nextpgGif", -width=>'39', -height=>'50', -border=>'0'}))); } my $hiddenFields; if ($url =~ /^(.+)\?(.*)$/) { $url = $1; my $hiddenVars = $2; if ($hiddenVars) { my @NmVal = split(/\&/, $hiddenVars); foreach my $NmVal (@NmVal) { my ($Nm, $Val) = split(/\=/, $NmVal); $hiddenFields .= hidden("$Nm", "$Val"); } } } my $listNavigation; if ($downloadfile) { $listNavigation = td({-align=>'center'}, startform({-method=>'POST', -action=>$url}). $hiddenFields. popup_menu(-name=>'navigateList', -"values"=>\@$navigateListRef). submit('Submit','Go!').br. " or ".a({-href=>"$downloadUrl"}, "Download All Data"). endform ); } else { $listNavigation = td({-align=>'center'}, startform({-method=>'POST', -action=>$url}). $hiddenFields. popup_menu(-name=>'navigateList', -"values"=>\@$navigateListRef). submit('Submit','Go!'). endform ); } my $listDisplay = td(startform({-method=>'POST', -action=>$url}). table({-width=>'100%', -border=>'1'}, Tr(td(" Sort by : ". $hiddenFields. popup_menu(-name=>'sortedBy', -"values"=>\@$sortListRef). submit('sortSubmit','Go!') )) ). table({-width=>'100%', -border=>'1'}, Tr(td(startform({-method=>'POST', -action=>$url}). " Search for : ". popup_menu(-name=>'searchFor', -"values"=>\@$sortListRef). " items containing : ". textfield(-name=>'filterBy', -size=>'10')." ". submit('searchSubmit','Go!') )) ) ); my $text; my $textspan = $colspan + 2; if ($pos =~ /top/i) { $text = Tr(td({-colspan=>"$textspan"}, "Do you need ".a({href=>$configUrl->dictyBaseHelp."navbar.html"}, "Help")." with the navigation bar? The search is case insensitive. You may use the ".b("wildcard character (*)."))); } return table({-width=>'100%', -border=>'1', -cellspacing=>'3', -cellpadding=>'0'}, Tr({-bgcolor=>"$barColor"}, th({-colspan=>"$colspan"}, "Page Navigation"). th("List Navigation"). th({-colspan=>'2'}, "List Sorting and Searching") ). Tr($pageNavigation. $listNavigation. $listDisplay ). $text ).endform; } ###################################################################### sub ResultNumber { ###################################################################### my (%args) = @_; my $totalHit = $args{'totalHit'}; my $showNum = $args{'showNum'} || 20; my $beg = $args{'beg'} || '1'; if ($totalHit <= $showNum) { return; } my $end = $beg + $showNum - 1; if ($end > $totalHit) { $end = $totalHit; } # if ($end > $totalHit) { return; } return table({-align=>'center', -border=>0, -cellpadding=>1, -cellspacing=>2, -bgcolor=>'#b7d8e4'}, Tr(td(b("Results $beg - $end of total $totalHit hits")))); } ###################################################################### sub ResultPageList { ###################################################################### my (%args) = @_; my $totalHit = $args{'totalHit'}; my $url = $args{'url'}; my $showNum = $args{'showNum'} || 20; my $beg = $args{'beg'} || '1'; my $cells = td(b("Result Page : ")); if ($beg != 1) { my $prevBeg = $beg - $showNum; if ($prevBeg < 1) { $prevBeg = 1; } $cells .= td(a({-href=>$url."&beg=$prevBeg"}, b("Previous"))); } my $start = 1; my $maxLinkNum = 20; if ($beg/$showNum >= 10 && $totalHit/$showNum > $maxLinkNum) { $start = $beg/$showNum - 9; if ($start < 1) { $start = 1; } } my $count; for (my $i = 1; $i < $totalHit; $i += $showNum) { $count++; if ($count < $start) { next; } if ($count >= $start + $maxLinkNum) { last; } if ($i == $beg) { $cells .= td(font({-color=>'red'}, b($count))); } else { $cells .= td(a({-href=>$url."&beg=$i"}, b($count))); } } if ($beg + $showNum < $totalHit) { my $nextBeg = $beg + $showNum; $cells .= td(a({-href=>$url."&beg=$nextBeg"}, b("Next"))); } return table({-align=>'center', -border=>0, -cellpadding=>1, -cellspacing=>2, -bgcolor=>'#b7d8e4'}, Tr($cells)); } ###################################################################### sub getUsernamePassword { ###################################################################### my ($username, $database) = @_; $database = "\U$database"; my $key = cookie($username); $username = "\U$username"; my $configPath = ConfigPathdictyBase->new; my $encryptedFile = $configPath->tmpDir.".user/$username.$database"; system("/usr/ucb/touch $encryptedFile"); my $passwd; if (-e "$encryptedFile") { my $clearFile = $configPath->tmpDir.".user/tmp.$$"; system("/usr/bin/crypt $key < $encryptedFile > $clearFile"); open(IN, "$clearFile") || return ($username, $passwd); while() { chomp; $passwd = $_; } close(IN); system("/usr/bin/rm $clearFile"); return ($username, $passwd); } return ($username, $passwd); } ##################################################################### sub getColleagueNoBYlname { ##################################################################### my ($dbh, $lname) = @_; $lname = "\U$lname"; $lname =~ s/^ *//; $lname =~ s/ *$//; my $sth = $dbh->prepare(" SELECT colleague_no FROM CGM_DDB.colleague WHERE upper(last_name) like ? "); $sth->execute($lname); my @id; while(my ($id) = $sth->fetchrow()) { push(@id, $id); } return @id; } ##################################################################### sub getColleagueNoBYlocus { ##################################################################### my ($dbh, $locus) = @_; my $sth; if ($locus =~ /^[0-9]+$/) { $sth = $dbh->prepare(" SELECT colleague_no FROM CGM_DDB.coll_locus WHERE locus_no = ? "); } else { $locus = "\U$locus"; $sth = $dbh->prepare(" SELECT CL.colleague_no FROM CGM_DDB.coll_locus CL, CGM_DDB.locus L WHERE CL.locus_no = L.locus_no AND upper(L.locus_name) = ? "); } $sth->execute($locus); my @id; while(my ($id) = $sth->fetchrow()) { push(@id, $id); } return @id; } ################################################################### sub getColleagueNoBYaceNm { ################################################################### my ($dbh, $aceNm) = @_; my $sth = $dbh->prepare( " SELECT primary_key FROM CGM_DDB.acelink WHERE tab_name = 'COLLEAGUE' AND ace_object = ? "); $sth->execute($aceNm); my $id = $sth->fetchrow; return $id; } ################################################################### sub getColleagueNoBYfullname { ################################################################### my ($dbh, $fullname) = @_; my ($lname, $fname) = split(/, /, $fullname); my @id = &getColleagueNoBYname($dbh, $lname, $fname); return @id; } ################################################################### sub getColleagueNoBYname { ################################################################### my ($dbh, $lname, $fname, $suffix) = @_; $lname = "\U$lname"; $fname = "\U$fname"; my $sth; if (!$suffix) { $sth = $dbh->prepare( " SELECT colleague_no FROM CGM_DDB.colleague WHERE upper(last_name) = ? AND upper(first_name) = ? "); $sth->execute($lname, $fname); } else { $sth = $dbh->prepare( " SELECT colleague_no FROM CGM_DDB.colleague WHERE upper(last_name) = ? AND upper(first_name) = ? AND suffix = ? "); $sth->execute($lname, $fname, $suffix); } my @id; while(my ($id) = $sth->fetchrow()) { push(@id, $id); } return @id; } ########################################################################### ###### getFeatureNoBYfeatureNm() is used to get the feature_no from feature ###### table for the specified feature_name ###### usage : $featNo = &getFeatureNoBYfeatureNm($dbh, $featureNm); ###### If the specified feature is found, it will return the feature_no, ###### otherwise return 0. ########################################################################### sub getFeatureNoBYfeatureNm { ########################################################################### my ($dbh, $featNm) = @_; $featNm = "\U$featNm"; my $sth = $dbh->prepare( " SELECT feature_no FROM CGM_DDB.feature WHERE upper(feature_name) = ? "); my $featNo; if ($sth->execute($featNm)) { while (my($number) = $sth->fetchrow()) { $featNo = $number; } } if (!$featNo) { $featNo = 0; } return $featNo; } ######################################################################## sub getFeatureNmBYfeatureNo { ######################################################################## my ($dbh, $featNo) = @_; my $sth = $dbh->prepare(" SELECT feature_name FROM CGM_DDB.feature WHERE feature_no = ? "); my $featNm; if ($sth->execute($featNo)) { while(my($name) = $sth->fetchrow()) { $featNm = $name; } } return $featNm; } ######################################################################## ###### getLocusNmBYfeatureNo() is used get std gene name for specified ###### feature_no. ###### Usage : $locus = &getLocusNmBYfeatureNo($dbh, $featNo); ###### If there is a gene name associted with the specified feature, ###### return gene name, otherwise return nothing ######################################################################## sub getLocusNmBYfeatureNo { ######################################################################## my ($dbh, $featNo) = @_; my $sth = $dbh->prepare( " SELECT L.locus_name FROM CGM_DDB.feature F, CGM_DDB.locus L WHERE F.feature_no = ? AND F.locus_no = L.locus_no "); my $locusNm; if ($sth->execute($featNo)) { while( my ($locus) = $sth->fetchrow()){ $locusNm = $locus; } } return $locusNm; } ###################################################################### ###### getLocusNmBylocusNo() is used to get locus_name from locus table ###### for the specified locus_no ###### Usage : $locusNm = &getLocusNmBYlocusNo($dbh, $locusNo); ###### If found, return the name, otherwise return empty string. ###################################################################### sub getLocusNmBYlocusNo { ###################################################################### my ($dbh, $locusNo) = @_; my $sth = $dbh->prepare(" SELECT locus_name FROM CGM_DDB.locus WHERE locus_no = ? "); my $locusNm; if ($sth->execute($locusNo)) { while (my ($name) = $sth->fetchrow()) { $locusNm = $name; } } return $locusNm; } ####################################################################### sub getLocusNoBYlocusNm { ####################################################################### my($dbh, $locusNm) = @_; $locusNm = "\U$locusNm"; my $sth = $dbh->prepare(" SELECT locus_no FROM CGM_DDB.locus WHERE upper(locus_name) = ? "); my $locusNo; if ($sth->execute($locusNm)) { while(my ($number) = $sth->fetchrow()) { $locusNo = $number; } } return $locusNo; } ####################################################################### ###### getFeatureNmBYlocusNo() is used to get Feature_name for the ###### specified locus_no ###### Usage: $featNm = &getFeatureNmBYlocusNo($dbh, $locusNo); ####################################################################### sub getFeatureNmBYlocusNo { ####################################################################### my($dbh, $locusNo) = @_; my $sth = $dbh->prepare(" SELECT feature_name FROM CGM_DDB.feature WHERE locus_no = ? "); $sth->execute($locusNo); my $featNm = $sth->fetchrow; return $featNm; } ####################################################################### sub getRefNoCitationlistFromRefLink { ####################################################################### my ($dbh, $tabNm, $prikey, $prikeyCol) = @_; my $sth = $dbh->prepare(" SELECT R.reference_no, R.citation FROM CGM_DDB.reflink RL, CGM_DDB.reference R WHERE RL.tab_name = ? AND RL.primary_key = ? AND RL.primary_key_col = ? AND RL.reference_no = R.reference_no "); $sth->execute($tabNm, $prikey, $prikeyCol); my $refNoCitationlist; while(my ($refNo, $citation) = $sth->fetchrow()){ $refNoCitationlist .= "\t"."${refNo}::$citation"; } $refNoCitationlist =~ s/^\t//; return $refNoCitationlist; } ####################################################################### sub getLocusArrayRefBYgpNo { ####################################################################### my ($dbh, $gpNo) = @_; my $sth = $dbh->prepare(" SELECT L.locus_no, L.locus_name FROM CGM_DDB.locus L, CGM_DDB.locus_gp LGP WHERE LGP.gene_product_no = ? AND L.locus_no = LGP.locus_no ORDER BY upper(L.locus_name) "); $sth->execute($gpNo); my $arrayRef = $sth->fetchall_arrayref(); $sth->finish; return $arrayRef; } ####################################################################### sub getLocusArrayRefBYgoid { ####################################################################### my ($dbh, $goid) = @_; my $sth = $dbh->prepare(" SELECT L.locus_no, L.locus_name FROM CGM_DDB.locus L, CGM_DDB.go_locus_goev GLG WHERE GLG.goid = ? AND GLG.locus_no = L.locus_no ORDER BY upper(L.locus_name) "); $sth->execute($goid); my $arrayRef = $sth->fetchall_arrayref(); $sth->finish; return $arrayRef; } ####################################################################### sub getFeatureArrayRefBYgoid { ####################################################################### my ($dbh, $goid) = @_; my $sth = $dbh->prepare(" SELECT F.feature_no, F.feature_name FROM CGM_DDB.feature F, CGM_DDB.go_feat_goev GFG WHERE GFG.goid = ? AND GFG.feature_no = F.feature_no ORDER BY upper(F.feature_name) "); $sth->execute($goid); my $arrayRef = $sth->fetchall_arrayref(); $sth->finish; return $arrayRef; } ####################################################################### ###### updateUpdateLog() is used to update description field in ###### update_log table ###### Usage: &updateUpdateLog($dbh, $tabNm, $colNm, $priKey, $oldVal, ###### $newVal, $desc); ####################################################################### sub updateUpdateLog { ####################################################################### my ($dbh, $tabNm, $colNm, $priKey, $oldVal, $newVal, $desc) = @_; $tabNm =~ s/[\t\n\r\f]//g; $colNm =~ s/[\t\n\r\f]//g; $priKey =~ s/[\t\n\r\f]//g; $oldVal =~ s/[\t\n\r\f]//g; $newVal =~ s/[\t\n\r\f]//g; $desc =~ s/[\t\n\r\f]/ /g; $tabNm = "\U$tabNm"; $colNm = "\U$colNm"; $priKey = "\U$priKey"; $oldVal = "\U$oldVal"; $newVal = "\U$newVal"; my $sth = $dbh->prepare(" UPDATE CGM_DDB.update_log set description = '$desc' WHERE tab_name = ? AND col_name = ? AND primary_key = ? AND upper(old_value) = ? AND upper(new_value) = ? "); $sth->execute($tabNm, $colNm, $priKey, $oldVal, $newVal); $dbh->commit; } ####################################################################### ###### updateDeleteLog() is used to update description column in ###### delete_log table ###### Usage: &updateDeleteLog($dbh, $tabNm, $deletedRow, $desc); ####################################################################### sub updateDeleteLog { ####################################################################### my ($dbh, $tabNm, $deletedRow, $desc) = @_; $desc =~ s/[\t\n\r\f]/ /g; my $sth = $dbh->prepare(" UPDATE CGM_DDB.delete_log set description = '$desc' WHERE tab_name = ? AND deleted_row = ? "); $sth->execute($tabNm, $deletedRow); $dbh->commit; } ####################################################################### sub insertRefLink { ####################################################################### my ($dbh, $refNo, $tabNm, $prikey, $prikeyCol) = @_; my $sth = $dbh->prepare(" INSERT INTO CGM_DDB.reflink(reflink_no, reference_no, tab_name, primary_key, primary_key_col) VALUES(CGM_DDB.reflinkno_seq.nextval, ?,?,?,?) "); eval { $sth->execute($refNo, $tabNm, $prikey, $prikeyCol); }; if ($@) { return $@; } else { $dbh->commit; return ; } } ######################################################################## sub insertLocusGeneInfo { ######################################################################## my ($dbh, $locusNo, $refNo, $topic) = @_; if (!$topic) { $topic = "Not yet curated"; } my $sth = $dbh->prepare(" INSERT INTO CGM_DDB.locus_gene_info(locus_no, reference_no, literature_topic) VALUES(?,?,?) "); eval { $sth->execute($locusNo, $refNo, $topic); }; $sth->finish; if ($@) { return $@; } else { $dbh->commit; return ; } } ######################################################################## sub insertFeatGeneInfo { ######################################################################## my ($dbh, $featNo, $refNo, $topic) = @_; if (!$topic) { $topic = "Not yet curated"; } my $sth = $dbh->prepare(" INSERT INTO CGM_DDB.feat_gene_info(feature_no, reference_no, literature_topic) VALUES(?,?,?) "); eval { $sth->execute($featNo, $refNo, $topic); }; $sth->finish; if ($@) { return $@; } else { $dbh->commit; return ; } } ######################################################################## sub getCDKeywords { ######################################################################## my ($dbh) = @_; my $sth = $dbh->prepare(" SELECT keyword FROM CGM_DDB.keyword WHERE source = 'Curator-defined' ORDER BY keyword "); $sth->execute(); my $listOfKeywords = ""; my $other; while (my $array_ref = $sth->fetchrow_arrayref()) { if ($array_ref->[0] =~ /^Other/) { $other = $array_ref->[0]; next; } $listOfKeywords .= "\t" . $array_ref->[0]; } $listOfKeywords .= "\t$other"; $listOfKeywords =~ s/^\t//; return $listOfKeywords; } ########################################################################### 1; ###########################################################################