[BACK]Return to lonsql CVS log [TXT] [DIR] Up to [LON-CAPA] / nsdl

Diff for /nsdl/lonsql between versions 1.1 and 1.4

version 1.1, 2005/09/26 19:00:29 version 1.4, 2005/11/17 22:51:59
Line 1 Line 1
 #!/usr/bin/perl  #!/usr/bin/perl
   
 # The LearningOnline Network  # The LearningOnline Network
 # lonsql - LON TCP-MySQL-Server Daemon for handling database requests.  # lonsql - LON TCP-NSDL Query Handler.
 #  #
 # $Id$  # $Id$
 #  #
Line 113  use IO::File; Line 113  use IO::File;
 use Socket;  use Socket;
 use Fcntl;  use Fcntl;
 use Tie::RefHash;  use Tie::RefHash;
 use DBI;  use HTML::LCParser();
   use LWP::UserAgent();
   use HTTP::Headers;
   use HTTP::Date;
 use File::Find;  use File::Find;
 use localenroll;  use localenroll;
   
 ########################################################  ########################################################
 ########################################################  ########################################################
   
 =pod  
   
 =item Global Variables  
   
 =over 4  
   
 =item dbh  
   
 =back  
   
 =cut  
   
 ########################################################  
 ########################################################  
 my $dbh;  
   
 ########################################################  
 ########################################################  
   
 =pod   =pod 
   
 =item Variables required for forking  =item Variables required for forking
Line 223  ENDMYCNF Line 207  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 364  sub make_new_child { Line 325  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 431  sub make_new_child { Line 379  sub make_new_child {
                 my $locresult = '';                  my $locresult = '';
                 my $querystr = &unescape($arg3);                  my $querystr = &unescape($arg3);
                 foreach (split/%%/,$querystr) {                  foreach (split/%%/,$querystr) {
                     if (/^(\w+)=([^=]+)$/) {                      if (/^([^=]+)=([^=]+)$/) {
                         @{$affiliates{$1}} = split/,/,$2;                          @{$affiliates{$1}} = split/,/,$2;
                     }                      }
                 }                  }
Line 465  sub make_new_child { Line 413  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.
Line 507  sub process_file { Line 452  sub process_file {
 }  }
   
 sub do_sql_query {  sub do_sql_query {
     my ($query,$custom,$customshow) = @_;      my ($query) = @_;
     &logthis('doing query '.$query);      &logthis('doing query '.$query);
     $custom     = &unescape($custom);   
     $customshow = &unescape($customshow);  
     #  
     @metalist = ();  
     #  
     my $result = '';  
     my @results = ();      my @results = ();
     my @files;   
     my $subsetflag=0;  
     #      #
     if ($query) {      if ($query) {
         #prepare and execute the query          #prepare and execute the query
         my $sth = $dbh->prepare($query);   my $aref=&nsdl_query($query);
         unless ($sth->execute()) {   foreach my $row (@$aref) {
             &logthis('<font color="blue">'.      my @b=map { &escape($_); } @$row;
                      'WARNING: Could not retrieve from database:'.      push @results,join(",", @b);
                      $sth->errstr().'</font>');   }
         } else {          
             my $aref=$sth->fetchall_arrayref;  
             foreach my $row (@$aref) {  
                 push @files,@{$row}[3] if ($custom or $customshow);  
                 my @b=map { &escape($_); } @$row;  
                 push @results,join(",", @b);  
                 # Build up the @files array with the LON-CAPA urls   
                 # of the resources.  
             }  
         }  
     }  
     # do custom metadata searching here and build into result  
     return join("&",@results) if (! ($custom or $customshow));  
     # Only get here if there is a custom query or custom show request  
     &logthis("Doing custom query for $custom");  
     if ($query) {  
         @metalist=map {  
             $perlvar{'lonDocRoot'}.$_.'.meta';  
         } @files;  
     } else {  
         my $dir = "$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}";  
         @metalist=();   
         opendir(RESOURCES,$dir);  
         my @homeusers=grep {  
             &ishome($dir.'/'.$_);  
         } grep {!/^\.\.?$/} readdir(RESOURCES);  
         closedir RESOURCES;  
         # Define the  
         foreach my $user (@homeusers) {  
             find (\&process_file,$dir.'/'.$user);  
         }  
     }   
     # if file is indicated in sql database and  
     #     not part of sql-relevant query, do not pattern match.  
     #  
     # if file is not in sql database, output error.  
     #  
     # if file is indicated in sql database and is  
     #     part of query result list, then do the pattern match.  
     my $customresult='';  
     my @results;  
     foreach my $metafile (@metalist) {  
         my $fh=IO::File->new($metafile);  
         my @lines=<$fh>;  
         my $stuff=join('',@lines);  
         if ($stuff=~/$custom/s) {  
             foreach my $f ('abstract','author','copyright',  
                            'creationdate','keywords','language',  
                            'lastrevisiondate','mime','notes',  
                            'owner','subject','title') {  
                 $stuff=~s/\n?\<$f[^\>]*\>.*?<\/$f[^\>]*\>\n?//s;  
             }  
             my $mfile=$metafile;   
             my $docroot=$perlvar{'lonDocRoot'};  
             $mfile=~s/^$docroot//;  
             $mfile=~s/\.meta$//;  
             unless ($query) {  
                 my $q2="SELECT * FROM metadata WHERE url ".  
                     " LIKE BINARY '?'";  
                 my $sth = $dbh->prepare($q2);  
                 $sth->execute($mfile);  
                 my $aref=$sth->fetchall_arrayref;  
                 foreach my $a (@$aref) {  
                     my @b=map { &escape($_)} @$a;  
                     push @results,join(",", @b);  
                 }  
             }  
             # &logthis("found: $stuff");  
             $customresult.='&custom='.&escape($mfile).','.  
                 escape($stuff);  
         }  
     }      }
     $result=join("&",@results) unless $query;      return join("&",@results);
     $result.=$customresult;  
     #  
     return $result;  
 } # End of &do_sql_query  } # End of &do_sql_query
   
 } # End of scoping curly braces for &process_file and &do_sql_query  } # End of scoping curly braces for &process_file and &do_sql_query
Line 976  sub HUPSMAN {                      # sig Line 842  sub HUPSMAN {                      # sig
     exec("$execdir/lonsql");         # here we go again      exec("$execdir/lonsql");         # here we go again
 }  }
   
 sub DISCONNECT {  #
     $dbh->disconnect or   # Takes SQL query
     &logthis("<font color='blue'>WARNING: Couldn't disconnect from database ".  # sends it to NSDL
              " $DBI::errstr : $@</font>");  # has to return array reference
     exit;  #
   
   sub nsdl_query {
       my $query=shift;
       my ($keyword)=($query=~/\"\%([^\%]+)\%\"/);
       $keyword=&escape($keyword);
       &logthis('Doing '.$keyword);
       my $url='http://search.nsdl.org?verb=Search&s=0&n=500&q='.$keyword;
       my $ua=new LWP::UserAgent;
       my $response=$ua->get($url);
       my $parser=HTML::LCParser->new(\$response->content);
       my %result=();
       my $is=();
       my $cont='';
       my $array=[];
       my $token;
       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
   #
       } elsif ($token->[1]=/^dc\:/) {
    $result{$is}=$cont;
       }
    }
       }
       return $array;
 }  }
   
   
 =pod  =pod
   
 =back  =back
Removed from v.1.1  
changed lines
  Added in v.1.4

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