Diff for /nsdl/lonsql between versions 1.10 and 1.11

version 1.10, 2005/11/29 21:02:52 version 1.11, 2006/07/28 17:55:18
Line 1 Line 1
 #!/usr/bin/perl  #!/usr/bin/perl
   
 # The LearningOnline Network  # The LearningOnline Network
 # lonsql - LON TCP-NSDL Query Handler.  # lonsql - LON TCP-MySQL-Server Daemon for handling database requests.
 #  #
 # $Id$  # $Id$
 #  #
Line 102  the database. Line 102  the database.
 use strict;  use strict;
   
 use lib '/home/httpd/lib/perl/';  use lib '/home/httpd/lib/perl/';
   use LONCAPA;
 use LONCAPA::Configuration;  use LONCAPA::Configuration;
 use LONCAPA::lonmetadata();  use LONCAPA::lonmetadata();
   
Line 113  use IO::File; Line 114  use IO::File;
 use Socket;  use Socket;
 use Fcntl;  use Fcntl;
 use Tie::RefHash;  use Tie::RefHash;
 use HTML::LCParser();  use DBI;
 use LWP::UserAgent();  
 use HTTP::Headers;  
 use HTTP::Date;  
 use File::Find;  use File::Find;
 use localenroll;  use localenroll;
   
   # FOR NSDL
   
    use HTML::LCParser();
    use LWP::UserAgent();
    use HTTP::Headers;
    use HTTP::Date;
   
   ########################################################
   ########################################################
   
   =pod
   
   =item Global Variables
   
   =over 4
   
   =item dbh
   
   =back
   
   =cut
   
   ########################################################
   ########################################################
   my $dbh;
   
 ########################################################  ########################################################
 ########################################################  ########################################################
   
Line 207  ENDMYCNF Line 231  ENDMYCNF
   
   
 #  #
   # Make sure that database can be accessed
   #
   my $dbh;
   unless ($dbh = DBI->connect("DBI:mysql:loncapa","www",
                               $perlvar{'lonSqlAccess'},
                               { RaiseError =>0,PrintError=>0})) { 
       print "Cannot connect to database!\n";
       my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
       my $subj="LON: $perlvar{'lonHostID'} Cannot connect to database!";
       system("echo 'Cannot connect to MySQL database!' |".
              " mailto $emailto -s '$subj' > /dev/null");
   
       open(SMP,'>/home/httpd/html/lon-status/mysql.txt');
       print SMP 'time='.time.'&mysql=defunct'."\n";
       close(SMP);
   
       exit 1;
   } else {
       unlink('/home/httpd/html/lon-status/mysql.txt');
       $dbh->disconnect;
   }
   
   #
 # Check if other instance running  # Check if other instance running
 #  #
 my $pidfile="$perlvar{'lonDaemons'}/logs/lonsql.pid";  my $pidfile="$perlvar{'lonDaemons'}/logs/lonsql.pid";
Line 221  if (-e $pidfile) { Line 268  if (-e $pidfile) {
 # Read hosts file  # Read hosts file
 #  #
 my $thisserver;  my $thisserver;
   my %hostname;
 my $PREFORK=4; # number of children to maintain, at least four spare  my $PREFORK=4; # number of children to maintain, at least four spare
 open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";  open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
 while (my $configline=<CONFIG>) {  while (my $configline=<CONFIG>) {
     my ($id,$domain,$role,$name)=split(/:/,$configline);      my ($id,$domain,$role,$name)=split(/:/,$configline);
     $name=~s/\s//g;      $name=~s/\s//g;
     $thisserver=$name if ($id eq $perlvar{'lonHostID'});      $thisserver=$name if ($id eq $perlvar{'lonHostID'});
       $hostname{$id}=$name;
     #$PREFORK++;      #$PREFORK++;
 }  }
 close(CONFIG);  close(CONFIG);
Line 325  sub make_new_child { Line 374  sub make_new_child {
         # unblock signals          # unblock signals
         sigprocmask(SIG_UNBLOCK, $sigset)          sigprocmask(SIG_UNBLOCK, $sigset)
             or die "Can't unblock SIGINT for fork: $!\n";              or die "Can't unblock SIGINT for fork: $!\n";
           #open database handle
    # making dbh global to avoid garbage collector
    unless ($dbh = DBI->connect("DBI:mysql:loncapa","www",
                                       $perlvar{'lonSqlAccess'},
                                       { RaiseError =>0,PrintError=>0})) { 
               sleep(10+int(rand(20)));
               &logthis("<font color='blue'>WARNING: Couldn't connect to database".
                        ": $@</font>");
                        #  "($st secs): $@</font>");
               print "database handle error\n";
               exit;
           }
    # make sure that a database disconnection occurs with 
           # ending kill signals
  $SIG{TERM}=$SIG{INT}=$SIG{QUIT}=$SIG{__DIE__}=\&DISCONNECT;   $SIG{TERM}=$SIG{INT}=$SIG{QUIT}=$SIG{__DIE__}=\&DISCONNECT;
         # handle connections until we've reached $MAX_CLIENTS_PER_CHILD          # handle connections until we've reached $MAX_CLIENTS_PER_CHILD
         for (my $i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {          for (my $i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
Line 334  sub make_new_child { Line 396  sub make_new_child {
     $run = $run+1;      $run = $run+1;
     my $userinput = <$client>;      my $userinput = <$client>;
     chomp($userinput);      chomp($userinput);
               $userinput=~s/\:(\w+)$//;
               my $searchdomain=$1;
             #              #
     my ($conserver,$query,      my ($conserver,$query,
  $arg1,$arg2,$arg3)=split(/&/,$userinput);   $arg1,$arg2,$arg3)=split(/&/,$userinput);
Line 371  sub make_new_child { Line 435  sub make_new_child {
                     $result='no_such_file';                      $result='no_such_file';
                 }                  }
                 # end of log query                  # end of log query
             } elsif ($query eq 'fetchenrollment') {              } elsif (($query eq 'fetchenrollment') || 
        ($query eq 'institutionalphotos')) {
                 # retrieve institutional class lists                  # retrieve institutional class lists
                 my $dom = &unescape($arg1);                  my $dom = &unescape($arg1);
                 my %affiliates = ();                  my %affiliates = ();
Line 383  sub make_new_child { Line 448  sub make_new_child {
                         @{$affiliates{$1}} = split/,/,$2;                          @{$affiliates{$1}} = split/,/,$2;
                     }                      }
                 }                  }
                 $locresult = &localenroll::fetch_enrollment($dom,\%affiliates,\%replies);                  if ($query eq 'fetchenrollment') { 
                       $locresult = &localenroll::fetch_enrollment($dom,\%affiliates,\%replies);
                   } elsif ($query eq 'institutionalphotos') {
                       my $crs = &unescape($arg2);
       eval {
    local($SIG{__DIE__})='DEFAULT';
    $locresult = &localenroll::institutional_photos($dom,$crs,\%affiliates,\%replies,'update');
       };
       if ($@) {
    $locresult = 'error';
       }
                   }
                 $result = &escape($locresult.':');                  $result = &escape($locresult.':');
                 if ($locresult) {                  if ($locresult) {
                     $result .= &escape(join(':',map{$_.'='.$replies{$_}} keys %replies));                      $result .= &escape(join(':',map{$_.'='.$replies{$_}} keys %replies));
Line 404  sub make_new_child { Line 480  sub make_new_child {
                 }                  }
             } else {              } else {
                 # Do an sql query                  # Do an sql query
                 $result = &nsdl_query($query,$arg1,$arg2);                  $result = &nsdl_query($query,$arg1,$arg2,$searchdomain);
             }              }
             # result does not need to be escaped because it has already been              # result does not need to be escaped because it has already been
             # escaped.              # escaped.
Line 413  sub make_new_child { Line 489  sub make_new_child {
         }          }
         # tidy up gracefully and finish          # tidy up gracefully and finish
         #          #
           # close the database handle
    $dbh->disconnect
               or &logthis("<font color='blue'>WARNING: Couldn't disconnect".
                           " from database  $DBI::errstr : $@</font>");
         # this exit is VERY important, otherwise the child will become          # this exit is VERY important, otherwise the child will become
         # a producer of more and more children, forking yourself into          # a producer of more and more children, forking yourself into
         # process death.          # process death.
         exit;          exit;
     }      }
 }  }
   
   
   ########################################################
   ########################################################
   
   #
   # Takes SQL query
   # sends it to NSDL
   #
   
   sub nsdl_query {
       my $query=shift;
       my ($keyword)=($query=~/\"\%([^\%]+)\%\"/);
       $keyword=&escape($keyword);
       my $url='http://search.nsdl.org?verb=Search&s=0&n=500&q=-link.primaryCollection:oai\:nsdl.org\:nsdl.nsdl\:00254%20'.$keyword;
       my $ua=new LWP::UserAgent;
       my $response=$ua->get($url);
       my $parser=HTML::LCParser->new(\$response->content);
       my $is='';
       my $cont='';
       my $token;
       my %result=();
       my $allresults='';
       while ($token=$parser->get_token) {
    if ($token->[0] eq 'T') {
       $cont.=$token->[1];
    } elsif ($token->[0] eq 'S') {
       if ($token->[1] eq 'record') {
    %result=();
       } elsif ($token->[1]=~/^dc\:/) {
    $is=$token->[1];
    $cont='';
       }
    } elsif ($token->[0] eq 'E') {
       if ($token->[1] eq 'record') {
   #
   # Now store it away
   #
                   my $url=$result{'dc:identifier'};
                   if ($url=~/^http\:/) {
                      $url=~s/^http:\//\/ext/;
                   } else {
                      $url='';
                   }
                   if ($url) {
                      my ($mime)=($url=~/\.(\w+)$/);
                      $mime=~tr/A-Z/a-z/;
      my $createdate=$result{'dc:date'};
      if ($createdate) {
          unless ($createdate=~/\:\d+$/) {
      $createdate.=' 00:00:00';
          }
      }
      unless ($createdate=~/^\d+\-\d+\-\d+\s+\d+\:\d+\:\d+$/) {
          $createdate='';
      }
                      $createdate=&escape($createdate);
   
                      $allresults.='&'.
                       &escape($result{'dc:title'}).','.
                       &escape($result{'dc:creator'}).','.
                       &escape($result{'dc:subject'}).','.
                       &escape($url).',,,,'.
                       &escape($result{'dc:description'}).','.
                       &escape($mime).',seniso,'.$createdate.','.$createdate.','.&escape('public@nsdl').
       ',public,nsdl,,,,,,,,,,,,,,,,,,,,,,,,,,,,';
                   }
                   %result=();
       } elsif ($token->[1]=~/^dc\:/) {
    $result{$is}=$cont;
       }
    }
       }
       $allresults=~s/^\&//;
   
       return $allresults;
   }
   
   
   ########################################################
 ########################################################  ########################################################
   
 =pod  =pod
Line 466  Returns: The results of the message or ' Line 625  Returns: The results of the message or '
 ########################################################  ########################################################
 sub subreply {  sub subreply {
     my ($cmd,$server)=@_;      my ($cmd,$server)=@_;
     my $peerfile="$perlvar{'lonSockDir'}/$server";      my $peerfile="$perlvar{'lonSockDir'}/".$hostname{$server};
     my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",      my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                                       Type    => SOCK_STREAM,                                        Type    => SOCK_STREAM,
                                       Timeout => 10)                                        Timeout => 10)
        or return "con_lost";         or return "con_lost";
     print $sclient "$cmd\n";      print $sclient "sethost:$server:$cmd\n";
     my $answer=<$sclient>;      my $answer=<$sclient>;
     chomp($answer);      chomp($answer);
     $answer="con_lost" if (!$answer);      $answer="con_lost" if (!$answer);
Line 516  sub reply { Line 675  sub reply {
   
 =pod  =pod
   
 =item &escape  
   
 Escape special characters in a string.  
   
 Inputs: string to escape  
   
 Returns: The input string with special characters escaped.  
   
 =cut  
   
 ########################################################  
 ########################################################  
 sub escape {  
     my $str=shift;  
     $str =~ s/(\W)/"%".unpack('H2',$1)/eg;  
     return $str;  
 }  
   
 ########################################################  
 ########################################################  
   
 =pod  
   
 =item &unescape  
   
 Unescape special characters in a string.  
   
 Inputs: string to unescape  
   
 Returns: The input string with special characters unescaped.  
   
 =cut  
   
 ########################################################  
 ########################################################  
 sub unescape {  
     my $str=shift;  
     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;  
     return $str;  
 }  
   
 ########################################################  
 ########################################################  
   
 =pod  
   
 =item &ishome  =item &ishome
   
 Determine if the current machine is the home server for a user.  Determine if the current machine is the home server for a user.
Line 790  sub HUPSMAN {                      # sig Line 903  sub HUPSMAN {                      # sig
     exec("$execdir/lonsql");         # here we go again      exec("$execdir/lonsql");         # here we go again
 }  }
   
 #  sub DISCONNECT {
 # Takes SQL query      $dbh->disconnect or 
 # sends it to NSDL      &logthis("<font color='blue'>WARNING: Couldn't disconnect from database ".
 #               " $DBI::errstr : $@</font>");
       exit;
 sub nsdl_query {  
     my $query=shift;  
     my ($keyword)=($query=~/\"\%([^\%]+)\%\"/);  
     $keyword=&escape($keyword);  
     my $url='http://search.nsdl.org?verb=Search&s=0&n=500&q=-link.primaryCollection:oai\:nsdl.org\:nsdl.nsdl\:00254%20'.$keyword;  
     my $ua=new LWP::UserAgent;  
     my $response=$ua->get($url);  
     my $parser=HTML::LCParser->new(\$response->content);  
     my $is='';  
     my $cont='';  
     my $token;  
     my %result=();  
     my $allresults='';  
     while ($token=$parser->get_token) {  
  if ($token->[0] eq 'T') {  
     $cont.=$token->[1];  
  } elsif ($token->[0] eq 'S') {  
     if ($token->[1] eq 'record') {  
  %result=();  
     } elsif ($token->[1]=~/^dc\:/) {  
  $is=$token->[1];  
  $cont='';  
     }  
  } elsif ($token->[0] eq 'E') {  
     if ($token->[1] eq 'record') {  
 #  
 # Now store it away  
 #  
                 my $url=$result{'dc:identifier'};  
                 if ($url=~/^http\:/) {  
                    $url=~s/^http:\//\/ext/;  
                 } else {  
                    $url='';  
                 }  
                 if ($url) {  
                    my ($mime)=($url=~/\.(\w+)$/);  
                    $mime=~tr/A-Z/a-z/;  
    my $createdate=$result{'dc:date'};  
    if ($createdate) {  
        unless ($createdate=~/\:\d+$/) {  
    $createdate.=' 00:00:00';  
        }  
    }  
    unless ($createdate=~/^\d+\-\d+\-\d+\s+\d+\:\d+\:\d+$/) {  
        $createdate='';  
    }  
                    $createdate=&escape($createdate);  
   
                    $allresults.='&'.  
                     &escape($result{'dc:title'}).','.  
                     &escape($result{'dc:creator'}).','.  
                     &escape($result{'dc:subject'}).','.  
                     &escape($url).',,,,'.  
                     &escape($result{'dc:description'}).','.  
                     &escape($mime).',seniso,'.$createdate.','.$createdate.','.&escape('public@nsdl').  
     ',public,nsdl,,,,,,,,,,,,,,,,,,,,,,,,,,,,';  
                 }  
                 %result=();  
     } elsif ($token->[1]=~/^dc\:/) {  
  $result{$is}=$cont;  
     }  
  }  
     }  
     $allresults=~s/^\&//;  
   
     return $allresults;  
 }  }
   
   
 =pod  =pod
   
 =back  =back

Removed from v.1.10  
changed lines
  Added in v.1.11


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>