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

Diff for /loncom/lonsql between versions 1.1 and 1.47

version 1.1, 2000/05/08 15:14:27 version 1.47, 2002/06/18 19:39:13
Line 1 Line 1
 #!/usr/bin/perl  #!/usr/bin/perl
   
 # The LearningOnline Network  # The LearningOnline Network
 # lonsql  # lonsql - LON TCP-MySQL-Server Daemon for handling database requests.
 # provides unix domain sockets to receive queries from lond and send replies to lonc  
 #  #
 # PID in subdir logs/lonc.pid  # $Id$
 # kill kills  #
 # HUP restarts  # Copyright Michigan State University Board of Trustees
 # USR1 tries to open connections again  #
   # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
 # 6/4/99,6/5,6/7,6/8,6/9,6/10,6/11,6/12,7/14,7/19,  #
 # 10/8,10/9,10/15,11/18,12/22,  # LON-CAPA is free software; you can redistribute it and/or modify
 # 2/8 Gerd Kortemeyer   # it under the terms of the GNU General Public License as published by
 # based on nonforker from Perl Cookbook  # the Free Software Foundation; either version 2 of the License, or
 # - server who multiplexes without forking  # (at your option) any later version.
   #
   # LON-CAPA is distributed in the hope that it will be useful,
   # but WITHOUT ANY WARRANTY; without even the implied warranty of
   # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   # GNU General Public License for more details.
   #
   # You should have received a copy of the GNU General Public License
   # along with LON-CAPA; if not, write to the Free Software
   # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
   #
   # /home/httpd/html/adm/gpl.txt
   #
   # http://www.lon-capa.org/
   #
   # YEAR=2000
   # lonsql-based on the preforker:harsha jagasia:date:5/10/00
   # 7/25 Gerd Kortemeyer
   # many different dates Scott Harrison
   # YEAR=2001
   # many different dates Scott Harrison
   # 03/22/2001 Scott Harrison
   # 8/30 Gerd Kortemeyer
   # 10/17,11/28,11/29,12/20 Scott Harrison
   # YEAR=2001
   # 5/11 Scott Harrison
   #
   ###
   
   ###############################################################################
   ##                                                                           ##
   ## ORGANIZATION OF THIS PERL SCRIPT                                          ##
   ## 1. Modules used                                                           ##
   ## 2. Enable find subroutine                                                 ##
   ## 3. Read httpd config files and get variables                              ##
   ## 4. Make sure that database can be accessed                                ##
   ## 5. Make sure this process is running from user=www                        ##
   ## 6. Check if other instance is running                                     ##
   ## 7. POD (plain old documentation, CPAN style)                              ##
   ##                                                                           ##
   ###############################################################################
   
   use lib '/home/httpd/lib/perl/';
   use LONCAPA::Configuration;
   
 use POSIX;  
 use IO::Socket;  use IO::Socket;
   use Symbol;
   use POSIX;
 use IO::Select;  use IO::Select;
 use IO::File;  use IO::File;
 use Socket;  use Socket;
 use Fcntl;  use Fcntl;
 use Tie::RefHash;  use Tie::RefHash;
 use Crypt::IDEA;  
 use DBI;  use DBI;
   
   my @metalist;
   # ----------------- Code to enable 'find' subroutine listing of the .meta files
   require "find.pl";
   sub wanted {
       (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
       -f _ &&
       /^.*\.meta$/ && !/^.+\.\d+\.[^\.]+\.meta$/ &&
       push(@metalist,"$dir/$_");
   }
   
 $childmaxattempts=10;  $childmaxattempts=10;
 $run =0;  $run =0;#running counter to generate the query-id
 # ------------------------------------ Read httpd access.conf and get variables  
   
 open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf";  
   
 while ($configline=<CONFIG>) {  # -------------------------------- Read loncapa_apache.conf and loncapa.conf
     if ($configline =~ /PerlSetVar/) {  my $perlvarref=LONCAPA::Configuration::read_conf('loncapa_apache.conf',
  my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);                                                   'loncapa.conf');
         chomp($varvalue);  my %perlvar=%{$perlvarref};
         $perlvar{$varname}=$varvalue;  
   # ------------------------------------- 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";
    $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
    $subj="LON: $perlvar{'lonHostID'} Cannot connect to database!";
    system("echo 'Cannot connect to MySQL database!' |\
    mailto $emailto -s '$subj' > /dev/null");
    exit 1;
       }
       else {
    $dbh->disconnect;
     }      }
 }  }
 close(CONFIG);  
   # --------------------------------------------- Check if other instance running
   
   my $pidfile="$perlvar{'lonDaemons'}/logs/lonsql.pid";
   
   if (-e $pidfile) {
      my $lfh=IO::File->new("$pidfile");
      my $pide=<$lfh>;
      chomp($pide);
      if (kill 0 => $pide) { die "already running"; }
   }
   
 # ------------------------------------------------------------- Read hosts file  # ------------------------------------------------------------- Read hosts file
 #$PREFORK=4; # number of children to maintain, at least four spare  $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";
   
Line 50  while ($configline=<CONFIG>) { Line 123  while ($configline=<CONFIG>) {
     my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);      my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
     chomp($ip);      chomp($ip);
   
     #$hostip{$ip}=$id;      $hostip{$ip}=$id;
     $hostip{$id}=$ip;  
   
     if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }      if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
   
     #$PREFORK++;      $PREFORK++;
 }  }
 close(CONFIG);  close(CONFIG);
   
   $PREFORK=int($PREFORK/4);
   
   $unixsock = "mysqlsock";
   my $localfile="$perlvar{'lonSockDir'}/$unixsock";
   my $server;
   unlink ($localfile);
   unless ($server=IO::Socket::UNIX->new(Local    =>"$localfile",
     Type    => SOCK_STREAM,
     Listen => 10))
   {
       print "in socket error:$@\n";
   }
   
 # -------------------------------------------------------- Routines for forking  # -------------------------------------------------------- Routines for forking
 # global variables  # global variables
 #$MAX_CLIENTS_PER_CHILD  = 5;        # number of clients each child should process  $MAX_CLIENTS_PER_CHILD  = 5;        # number of clients each child should process
 %children               = ();       # keys are current child process IDs  %children               = ();       # keys are current child process IDs
 #$children               = 0;        # current number of children  $children               = 0;        # current number of children
 %childpid               = ();       # the other way around  
   
 %childatt               = ();       # number of attempts to start server  
                                     # for ID  
   
   
 sub REAPER {                        # takes care of dead children  sub REAPER {                        # takes care of dead children
     $SIG{CHLD} = \&REAPER;      $SIG{CHLD} = \&REAPER;
     my $pid = wait;      my $pid = wait;
       $children --;
     #$children --;      &logthis("Child $pid died");
     #&logthis("Child $pid died");  
     #delete $children{$pid};  
       
     my $wasserver=$children{$pid};  
     &logthis("<font color=red>CRITICAL: "  
      ."Child $pid for server $wasserver died ($childatt{$wasserver})</font>");  
     delete $children{$pid};      delete $children{$pid};
     delete $childpid{$wasserver};  
     my $port = "$perlvar{'lonSockDir'}/$wasserver";  
     unlink($port);  
   
   
 }  }
   
 sub HUNTSMAN {                      # signal handler for SIGINT  sub HUNTSMAN {                      # signal handler for SIGINT
Line 96  sub HUNTSMAN {                      # si Line 163  sub HUNTSMAN {                      # si
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     unlink("$execdir/logs/lonsql.pid");      unlink("$execdir/logs/lonsql.pid");
     &logthis("<font color=red>CRITICAL: Shutting down</font>");      &logthis("<font color=red>CRITICAL: Shutting down</font>");
       $unixsock = "mysqlsock";
       my $port="$perlvar{'lonSockDir'}/$unixsock";
       unlink(port);
     exit;                           # clean up with dignity      exit;                           # clean up with dignity
 }  }
   
Line 105  sub HUPSMAN {                      # sig Line 175  sub HUPSMAN {                      # sig
     close($server);                # free up socket      close($server);                # free up socket
     &logthis("<font color=red>CRITICAL: Restarting</font>");      &logthis("<font color=red>CRITICAL: Restarting</font>");
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
       $unixsock = "mysqlsock";
       my $port="$perlvar{'lonSockDir'}/$unixsock";
       unlink(port);
     exec("$execdir/lonsql");         # here we go again      exec("$execdir/lonsql");         # here we go again
 }  }
   
 sub logthis {  sub logthis {
     my $message=shift;      my $message=shift;
     my $execdir=$perlvar{'lonDaemons'};      my $execdir=$perlvar{'lonDaemons'};
     my $fh=IO::File->new(">>$execdir/logs/lonsql.log");      my $fh=IO::File->new(">>$execdir/logs/lonsqlfinal.log");
     my $now=time;      my $now=time;
     my $local=localtime($now);      my $local=localtime($now);
     print $fh "$local ($$): $message\n";      print $fh "$local ($$): $message\n";
 }  }
   
 # ----------------------------------------------------------- Send USR1 to lonc  # ------------------------------------------------------------------ Course log
 sub reconlonc {  
     my $peerfile=shift;  sub courselog {
     &logthis("Trying to reconnect for $peerfile");      my ($path,$command)=@_;
     my $loncfile="$perlvar{'lonDaemons'}/logs/lonc.pid";      my %filters=();
     if (my $fh=IO::File->new("$loncfile")) {      foreach (split(/\:/,&unescape($command))) {
  my $loncpid=<$fh>;   my ($name,$value)=split(/\=/,$_);
         chomp($loncpid);          $filters{$name}=$value;
         if (kill 0 => $loncpid) {      }
     &logthis("lonc at pid $loncpid responding, sending USR1");      my @results=();
             kill USR1 => $loncpid;      open(IN,$path.'/activity.log') or return ('file_error');
             sleep 1;      while ($line=<IN>) {
             if (-e "$peerfile") { return; }          chomp($line);
             &logthis("$peerfile still not there, give it another try");          my ($timestamp,$host,$log)=split(/\:/,$line);
             sleep 5;          foreach (split(/\&/,&unescape($log))) {
             if (-e "$peerfile") { return; }      my ($time,$res,$uname,$udom,$action,$values)=split(/\:/,$_);
             &logthis(              my $include=1;
  "<font color=blue>WARNING: $peerfile still not there, giving up</font>");              if (($filters{'username'}) && ($uname ne $filters{'username'})) 
         } else {                                                                 { $include=0; }
     &logthis(              if (($filters{'domain'}) && ($udom ne $filters{'domain'})) 
               "<font color=red>CRITICAL: "                                                                 { $include=0; }
              ."lonc at pid $loncpid not responding, giving up</font>");              if (($filters{'url'}) && ($res!~/$filters{'url'}/)) 
         }                                                                 { $include=0; }
     } else {              if (($filters{'start'}) && ($time<$filters{'start'})) 
       &logthis('<font color=red>CRITICAL: lonc not running, giving up</font>');                                                                 { $include=0; }
               if (($filters{'end'}) && ($time>$filters{'end'})) 
                                                                  { $include=0; }
               if (($filters{'action'} eq 'view') && ($action)) 
                                                                  { $include=0; }
               if (($filters{'action'} eq 'submit') && ($action ne 'POST')) 
                                                                  { $include=0; }
               if (($filters{'action'} eq 'grade') && ($action ne 'CSTORE')) 
                                                                  { $include=0; }
               if ($include) {
          push(@results,$time.':'.$res.':'.$uname.':'.$udom.':'.
                                               $action.':'.$values);
               }
          }
     }      }
       close IN;
       return join('&',sort(@results));
 }  }
   
 # -------------------------------------------------- Non-critical communication  # -------------------------------------------------------------------- User log
 sub subreply {  
     my ($cmd,$server)=@_;  
     my $peerfile="$perlvar{'lonSockDir'}/$server";  
     my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",  
                                       Type    => SOCK_STREAM,  
                                       Timeout => 10)  
        or return "con_lost";  
     print $sclient "$cmd\n";  
     my $answer=<$sclient>;  
     chomp($answer);  
     if (!$answer) { $answer="con_lost"; }  
     return $answer;  
 }  
   
 sub reply {  sub userlog {
   my ($cmd,$server)=@_;      my ($path,$command)=@_;
   my $answer;      my %filters=();
   if ($server ne $perlvar{'lonHostID'}) {       foreach (split(/\:/,&unescape($command))) {
     $answer=subreply($cmd,$server);   my ($name,$value)=split(/\=/,$_);
     if ($answer eq 'con_lost') {          $filters{$name}=$value;
  $answer=subreply("ping",$server);      }
         if ($answer ne $server) {      my @results=();
            &reconlonc("$perlvar{'lonSockDir'}/$server");      open(IN,$path.'/activity.log') or return ('file_error');
       while ($line=<IN>) {
           chomp($line);
           my ($timestamp,$host,$log)=split(/\:/,$line);
           $log=&unescape($log);
           my $include=1;
           if (($filters{'action'} eq 'log') && ($log!~/^Log/)) { $include=0; }
           if ($include) {
      push(@results,$timestamp.':'.$log);
         }          }
         $answer=subreply($cmd,$server);  
     }      }
   } else {      close IN;
     $answer='self_reply';      return join('&',sort(@results));
   }   
   return $answer;  
 }  }
   
 $unixsock = "msua1_sql";  
 my $localfile="$perlvar{'lonSockDir'}/$unixsock";  
 my $server=IO::Socket::UNIX->new(LocalAddr    =>"$localfile",  
   Type    => SOCK_STREAM,  
   Timeout => 10);  
   
 # ---------------------------------------------------- Fork once and dissociate  # ---------------------------------------------------- Fork once and dissociate
 $fpid=fork;  $fpid=fork;
Line 201  close(PIDSAVE); Line 276  close(PIDSAVE);
   
 # ----------------------------- Ignore signals generated during initial startup  # ----------------------------- Ignore signals generated during initial startup
 $SIG{HUP}=$SIG{USR1}='IGNORE';  $SIG{HUP}=$SIG{USR1}='IGNORE';
   # ------------------------------------------------------- Now we are on our own    
 # ------------------------------------------------------- Now we are on our own  # Fork off our children.
 #Fork of children one for every server  for (1 .. $PREFORK) {
       make_new_child();
 #for (1 .. $PREFORK) {  
 #    make_new_child($thisserver);  
 #}  
   
 foreach $thisserver (keys %hostip) {   
     make_new_child($thisserver);  
 }  }
   
 &logthis("Done starting initial servers");  # Install signal handlers.
 # ----------------------------------------------------- Install signal handlers  
   
 $SIG{CHLD} = \&REAPER;  $SIG{CHLD} = \&REAPER;
 $SIG{INT}  = $SIG{TERM} = \&HUNTSMAN;  $SIG{INT}  = $SIG{TERM} = \&HUNTSMAN;
 $SIG{HUP}  = \&HUPSMAN;  $SIG{HUP}  = \&HUPSMAN;
Line 223  $SIG{HUP}  = \&HUPSMAN; Line 290  $SIG{HUP}  = \&HUPSMAN;
 # And maintain the population.  # And maintain the population.
 while (1) {  while (1) {
     sleep;                          # wait for a signal (i.e., child's death)      sleep;                          # wait for a signal (i.e., child's death)
       for ($i = $children; $i < $PREFORK; $i++) {
     #for ($i = $children; $i < $PREFORK; $i++) {          make_new_child();           # top up the child pool
     #   make_new_child();           # top up the child pool  
     #}  
       
     foreach $thisserver (keys %hostip) {  
         if (!$childpid{$thisserver}) {  
     if ($childatt{$thisserver}<=$childmaxattempts) {  
        $childatt{$thisserver}++;  
                &logthis(  
    "<font color=yellow>INFO: Trying to reconnect for $thisserver "  
   ."($childatt{$thisserver} of $childmaxattempts attempts)</font>");   
                make_new_child($thisserver);  
     }  
         }         
     }      }
 }  }
   
   
 sub make_new_child {  sub make_new_child {
     my $conserver=shift;  
     my $pid;      my $pid;
     my $sigset;      my $sigset;
     my $queryid;      
   
     &logthis("Attempting to start child");      
     # block signal for fork      # block signal for fork
     $sigset = POSIX::SigSet->new(SIGINT);      $sigset = POSIX::SigSet->new(SIGINT);
     sigprocmask(SIG_BLOCK, $sigset)      sigprocmask(SIG_BLOCK, $sigset)
         or die "Can't block SIGINT for fork: $!\n";          or die "Can't block SIGINT for fork: $!\n";
           
     die "fork: $!" unless defined ($pid = fork);#do the forking of children      die "fork: $!" unless defined ($pid = fork);
       
     if ($pid) {      if ($pid) {
         # Parent records the child's birth and returns.          # Parent records the child's birth and returns.
         sigprocmask(SIG_UNBLOCK, $sigset)          sigprocmask(SIG_UNBLOCK, $sigset)
Line 263  sub make_new_child { Line 315  sub make_new_child {
         $children++;          $children++;
         return;          return;
     } else {      } else {
        # Child can *not* return from this subroutine.          # Child can *not* return from this subroutine.
         $SIG{INT} = 'DEFAULT';      # make SIGINT kill us as it did before          $SIG{INT} = 'DEFAULT';      # make SIGINT kill us as it did before
           
         # 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";
   
         #connect to the database  
           #open database handle
    # making dbh global to avoid garbage collector
  unless (   unless (
  my $dbh = DBI->connect("DBI:mysql:loncapa","root","mysql",{ RaiseError =>1,})   $dbh = DBI->connect("DBI:mysql:loncapa","www",$perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0})
  ) {    ) { 
             my $st=120+int(rand(240));               sleep(10+int(rand(20)));
     &logthis("<font color=blue>WARNING: Couldn't connect to database  ($st secs): $@</font>");      &logthis("<font color=blue>WARNING: Couldn't connect to database  ($st secs): $@</font>");
     sleep($st);      print "database handle error\n";
     exit;#do I need to cleanup before exit if can't connect to database       exit;
  };  
     };
    # make sure that a database disconnection occurs with ending kill signals
    $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 ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {          for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
             $client = $server->accept()     or last;              $client = $server->accept()     or last;
     $run = $run+1;              
 # =============================================================================  
             # do something with the connection              # do something with the connection
 # -----------------------------------------------------------------------------      $run = $run+1;
     my $userinput = "1";      my $userinput = <$client>;
     #while (my $userinput=<$client>) {      chomp($userinput);
     while (my $userinput="1") {          
     print ("here we go\n");      my ($conserver,$query,
  chomp($userinput);   $arg1,$arg2,$arg3)=split(/&/,$userinput);
         my $query=unescape($query);
  #send query id which is pid_unixdatetime_runningcounter  
  $queryid = $conserver;               #send query id which is pid_unixdatetime_runningcounter
  $queryid .=($$)."_";      $queryid = $thisserver;
  $queryid .= time."_";      $queryid .="_".($$)."_";
  $queryid .= run;      $queryid .= time."_";
  print $client "$queryid\n";      $queryid .= $run;
       print $client "$queryid\n";
  #prepare and execute the query      
         &logthis("QUERY: $query - $arg1 - $arg2 - $arg3");
  my $sth = $dbh->prepare("select * into outfile \"$queryid\" from resource");#can't use $userinput directly since we the query to write to a file which depends on the query id generated       sleep 1;
     
  $sth->execute();              my $result='';
  if (-e "$queryid") { print "Oops ,file is already there!\n";}  
  else  # ---------- At this point, query is received, query-ID assigned and sent back 
  {  # $query eq 'logquery' will mean that this is a query against log-files
      print "error reading into file\n";  
  }  
        if (($query eq 'userlog') || ($query eq 'courselog')) {
                  #connect to lonc and send the query results  # ----------------------------------------------------- beginning of log query
  $reply = reply($queryid,$conserver);  #
     # this goes against a user's log file
      }  #
 # =============================================================================         my $udom=&unescape($arg1);
          my $uname=&unescape($arg2);
                  my $command=&unescape($arg3);
                  my $path=&propath($udom,$uname);
                  if (-e "$path/activity.log") {
      if ($query eq 'userlog') {
                          $result=&userlog($path,$command);
                      } else {
                          $result=&courselog($path,$command);
                      }
                  } else {
      &logthis('Unable to do log query: '.$uname.'@'.$udom);
              $result='no_such_file';
          }
   # ------------------------------------------------------------ end of log query
             } else {
   # -------------------------------------------------------- This is an sql query
       my $custom=unescape($arg1);
       my $customshow=unescape($arg2);
               #prepare and execute the query
       my $sth = $dbh->prepare($query);
   
       my @files;
       my $subsetflag=0;
       if ($query) {
    unless ($sth->execute())
    {
       &logthis("<font color=blue>WARNING: Could not retrieve from database: $@</font>");
       $result="";
    }
    else {
       my $r1=$sth->fetchall_arrayref;
       my @r2;
       foreach (@$r1) {my $a=$_; 
    my @b=map {escape($_)} @$a;
    push @files,@{$a}[3];
    push @r2,join(",", @b)
    }
       $result=join("&",@r2);
    }
       }
       # do custom metadata searching here and build into result
       if ($custom or $customshow) {
    &logthis("am going to do custom query for $custom");
    if ($query) {
       @metalist=map {$perlvar{'lonDocRoot'}.$_.'.meta'} @files;
    }
    else {
       @metalist=(); pop @metalist;
       opendir(RESOURCES,"$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}");
       my @homeusers=grep
             {&ishome("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$_")}
             grep {!/^\.\.?$/} readdir(RESOURCES);
       closedir RESOURCES;
       foreach my $user (@homeusers) {
    &find("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$user");
       }
    }
   # &logthis("FILELIST:" . join(":::",@metalist));
    # 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 @r2;
    foreach my $m (@metalist) {
       my $fh=IO::File->new($m);
       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 $m2=$m; my $docroot=$perlvar{'lonDocRoot'};
    $m2=~s/^$docroot//;
    $m2=~s/\.meta$//;
    unless ($query) {
       my $q2="select * from metadata where url like binary '$m2'";
       my $sth = $dbh->prepare($q2);
       $sth->execute();
       my $r1=$sth->fetchall_arrayref;
       foreach (@$r1) {my $a=$_; 
    my @b=map {escape($_)} @$a;
    push @files,@{$a}[3];
    push @r2,join(",", @b)
    }
    }
   # &logthis("found: $stuff");
    $customresult.='&custom='.escape($m2).','.escape($stuff);
       }
    }
    $result=join("&",@r2) unless $query;
    $result.=$customresult;
       }
   # ------------------------------------------------------------ end of sql query
      }
   
               # result does need to be escaped
   
               $result=&escape($result);
   
       # reply with result, append \n unless already there
   
       $result.="\n" unless ($result=~/\n$/);
               &reply("queryreply:$queryid:$result",$conserver);
   
         }          }
           
         # 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 ($st secs): $@</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;
     }      }
 }     }
       
   
       sub DISCONNECT {
       $dbh->disconnect or 
       &logthis("<font color=blue>WARNING: Couldn't disconnect from database  $DBI::errstr ($st secs): $@</font>");
       exit;
   }
   
   # -------------------------------------------------- Non-critical communication
   
   sub subreply {
       my ($cmd,$server)=@_;
       my $peerfile="$perlvar{'lonSockDir'}/$server";
       my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                                         Type    => SOCK_STREAM,
                                         Timeout => 10)
          or return "con_lost";
       print $sclient "$cmd\n";
       my $answer=<$sclient>;
       chomp($answer);
       if (!$answer) { $answer="con_lost"; }
       return $answer;
   }
   
   sub reply {
     my ($cmd,$server)=@_;
     my $answer;
     if ($server ne $perlvar{'lonHostID'}) { 
       $answer=subreply($cmd,$server);
       if ($answer eq 'con_lost') {
    $answer=subreply("ping",$server);
           $answer=subreply($cmd,$server);
       }
     } else {
       $answer='self_reply';
       $answer=subreply($cmd,$server);
     } 
     return $answer;
   }
   
   # -------------------------------------------------------- Escape Special Chars
   
   sub escape {
       my $str=shift;
       $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
       return $str;
   }
   
   # ----------------------------------------------------- Un-Escape Special Chars
   
   sub unescape {
       my $str=shift;
       $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
       return $str;
   }
   
   # --------------------------------------- Is this the home server of an author?
   # (copied from lond, modification of the return value)
   sub ishome {
       my $author=shift;
       $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
       my ($udom,$uname)=split(/\//,$author);
       my $proname=propath($udom,$uname);
       if (-e $proname) {
    return 1;
       } else {
           return 0;
       }
   }
   
   # -------------------------------------------- Return path to profile directory
   # (copied from lond)
   sub propath {
       my ($udom,$uname)=@_;
       $udom=~s/\W//g;
       $uname=~s/\W//g;
       my $subdir=$uname.'__';
       $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
       my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
       return $proname;
   } 
   
   # ----------------------------------- POD (plain old documentation, CPAN style)
   
   =head1 NAME
   
   lonsql - LON TCP-MySQL-Server Daemon for handling database requests.
   
   =head1 SYNOPSIS
   
   This script should be run as user=www.  The following is an example invocation
   from the loncron script.  Note that a lonsql.pid file contains the pid of
   the parent process.
   
       if (-e $lonsqlfile) {
    my $lfh=IO::File->new("$lonsqlfile");
    my $lonsqlpid=<$lfh>;
    chomp($lonsqlpid);
    if (kill 0 => $lonsqlpid) {
       print $fh "<h3>lonsql at pid $lonsqlpid responding</h3>";
       $restartflag=0;
    } else {
       $errors++; $errors++;
       print $fh "<h3>lonsql at pid $lonsqlpid not responding</h3>";
    $restartflag=1;
    print $fh 
       "<h3>Decided to clean up stale .pid file and restart lonsql</h3>";
    }
       }
       if ($restartflag==1) {
    $errors++;
            print $fh '<br><font color="red">Killall lonsql: '.
                       system('killall lonsql').' - ';
                       sleep 60;
                       print $fh unlink($lonsqlfile).' - '.
                                 system('killall -9 lonsql').
                       '</font><br>';
    print $fh "<h3>lonsql not running, trying to start</h3>";
    system(
    "$perlvar{'lonDaemons'}/lonsql 2>>$perlvar{'lonDaemons'}/logs/lonsql_errors");
    sleep 10;
   
   =head1 DESCRIPTION
   
   Not yet written.
   
   =head1 README
   
   Not yet written.
   
   =head1 PREREQUISITES
   
   IO::Socket
   Symbol
   POSIX
   IO::Select
   IO::File
   Socket
   Fcntl
   Tie::RefHash
   DBI
   
   =head1 COREQUISITES
   
   =head1 OSNAMES
   
   linux
   
   =head1 SCRIPT CATEGORIES
   
   Server/Process
   
   =cut
Removed from v.1.1  
changed lines
  Added in v.1.47

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