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

Diff for /nsdl/lonsql between versions 1.1 and 1.8

version 1.1, 2005/09/26 19:00:29 version 1.8, 2005/11/25 21:18:35
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 456  sub make_new_child { Line 404  sub make_new_child {
                 }                  }
             } else {              } else {
                 # Do an sql query                  # Do an sql query
                 $result = &do_sql_query($query,$arg1,$arg2);                  $result = &nsdl_query($query,$arg1,$arg2);
             }              }
             # 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 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.
         exit;          exit;
     }      }
 }  }
   
 ########################################################  
 ########################################################  
   
 =pod  
   
 =item &do_sql_query  
   
 Runs an sql metadata table query.  
   
 Inputs: $query, $custom, $customshow  
   
 Returns: A string containing escaped results.  
   
 =cut  
   
 ########################################################  
 ########################################################  
 {  
     my @metalist;  
   
 sub process_file {  
     if ( -e $_ &&  # file exists  
          -f $_ &&  # and is a normal file  
          /\.meta$/ &&  # ends in meta  
          ! /^.+\.\d+\.[^\.]+\.meta$/  # is not a previous version  
          ) {  
         push(@metalist,$File::Find::name);  
     }  
 }  
   
 sub do_sql_query {  
     my ($query,$custom,$customshow) = @_;  
     &logthis('doing query '.$query);  
     $custom     = &unescape($custom);  
     $customshow = &unescape($customshow);  
     #  
     @metalist = ();  
     #  
     my $result = '';  
     my @results = ();  
     my @files;  
     my $subsetflag=0;  
     #  
     if ($query) {  
         #prepare and execute the query  
         my $sth = $dbh->prepare($query);  
         unless ($sth->execute()) {  
             &logthis('<font color="blue">'.  
                      'WARNING: Could not retrieve from database:'.  
                      $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;  
     $result.=$customresult;  
     #  
     return $result;  
 } # End of &do_sql_query  
   
 } # End of scoping curly braces for &process_file and &do_sql_query  
 ########################################################  
 ########################################################  ########################################################
   
 =pod  =pod
Line 976  sub HUPSMAN {                      # sig Line 790  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>");  #
     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/;
                      $allresults.='&'.
                       &escape($result{'dc:title'}).','.
                       &escape($result{'dc:creator'}).','.
                       &escape($result{'dc:subject'}).','.
                       &escape($url).',,,,'.
                       &escape($result{'dc:description'}).','.
                       &escape($mime).',seniso,,,,public,nsdl,,,,,,,,,,,,,,,,,,,,,,,,,,,,';
                   }
                   %result=();
       } elsif ($token->[1]=~/^dc\:/) {
    $result{$is}=$cont;
       }
    }
       }
       $allresults=~s/^\&//;
   &logthis($allresults);
       return $allresults;
   }
   
 =pod  =pod
   
Removed from v.1.1  
changed lines
  Added in v.1.8

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