[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>
500 Internal Server Error

Internal Server Error

The server encountered an internal error or misconfiguration and was unable to complete your request.

Please contact the server administrator at root@localhost to inform them of the time this error occurred, and the actions you performed just before this error.

More information about this error may be available in the server error log.