Annotation of loncom/lonsql, revision 1.45

1.1       harris41    1: #!/usr/bin/perl
1.39      harris41    2: 
                      3: # The LearningOnline Network
1.40      harris41    4: # lonsql - LON TCP-MySQL-Server Daemon for handling database requests.
1.39      harris41    5: #
1.45    ! www         6: # $Id: lonsql,v 1.44 2002/06/17 14:00:09 www Exp $
1.41      harris41    7: #
                      8: # Copyright Michigan State University Board of Trustees
                      9: #
                     10: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
                     11: #
                     12: # LON-CAPA is free software; you can redistribute it and/or modify
                     13: # it under the terms of the GNU General Public License as published by
                     14: # the Free Software Foundation; either version 2 of the License, or
                     15: # (at your option) any later version.
                     16: #
                     17: # LON-CAPA is distributed in the hope that it will be useful,
                     18: # but WITHOUT ANY WARRANTY; without even the implied warranty of
                     19: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
                     20: # GNU General Public License for more details.
                     21: #
                     22: # You should have received a copy of the GNU General Public License
                     23: # along with LON-CAPA; if not, write to the Free Software
                     24: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
                     25: #
                     26: # /home/httpd/html/adm/gpl.txt
                     27: #
                     28: # http://www.lon-capa.org/
                     29: #
1.39      harris41   30: # YEAR=2000
1.2       harris41   31: # lonsql-based on the preforker:harsha jagasia:date:5/10/00
1.4       www        32: # 7/25 Gerd Kortemeyer
1.6       harris41   33: # many different dates Scott Harrison
1.39      harris41   34: # YEAR=2001
                     35: # many different dates Scott Harrison
1.7       harris41   36: # 03/22/2001 Scott Harrison
1.36      www        37: # 8/30 Gerd Kortemeyer
1.41      harris41   38: # 10/17,11/28,11/29,12/20 Scott Harrison
1.42      harris41   39: # YEAR=2001
                     40: # 5/11 Scott Harrison
1.39      harris41   41: #
                     42: ###
                     43: 
1.40      harris41   44: ###############################################################################
                     45: ##                                                                           ##
                     46: ## ORGANIZATION OF THIS PERL SCRIPT                                          ##
                     47: ## 1. Modules used                                                           ##
                     48: ## 2. Enable find subroutine                                                 ##
1.43      matthew    49: ## 3. Read httpd config files and get variables                              ##
1.40      harris41   50: ## 4. Make sure that database can be accessed                                ##
                     51: ## 5. Make sure this process is running from user=www                        ##
                     52: ## 6. Check if other instance is running                                     ##
                     53: ## 7. POD (plain old documentation, CPAN style)                              ##
                     54: ##                                                                           ##
                     55: ###############################################################################
1.36      www        56: 
1.42      harris41   57: use lib '/home/httpd/lib/perl/';
                     58: use LONCAPA::Configuration;
                     59: 
1.2       harris41   60: use IO::Socket;
                     61: use Symbol;
1.1       harris41   62: use POSIX;
                     63: use IO::Select;
                     64: use IO::File;
                     65: use Socket;
                     66: use Fcntl;
                     67: use Tie::RefHash;
                     68: use DBI;
                     69: 
1.9       harris41   70: my @metalist;
                     71: # ----------------- Code to enable 'find' subroutine listing of the .meta files
                     72: require "find.pl";
                     73: sub wanted {
                     74:     (($dev,$ino,$mode,$nlink,$uid,$gid) = lstat($_)) &&
                     75:     -f _ &&
1.34      harris41   76:     /^.*\.meta$/ && !/^.+\.\d+\.[^\.]+\.meta$/ &&
1.9       harris41   77:     push(@metalist,"$dir/$_");
                     78: }
                     79: 
1.1       harris41   80: $childmaxattempts=10;
1.2       harris41   81: $run =0;#running counter to generate the query-id
                     82: 
1.43      matthew    83: # -------------------------------- Read loncapa_apache.conf and loncapa.conf
                     84: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa_apache.conf',
                     85:                                                  'loncapa.conf');
1.42      harris41   86: my %perlvar=%{$perlvarref};
1.4       www        87: 
1.31      harris41   88: # ------------------------------------- Make sure that database can be accessed
                     89: {
                     90:     my $dbh;
                     91:     unless (
                     92: 	    $dbh = DBI->connect("DBI:mysql:loncapa","www",$perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0})
                     93: 	    ) { 
                     94: 	print "Cannot connect to database!\n";
1.38      harris41   95: 	$emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
                     96: 	$subj="LON: $perlvar{'lonHostID'} Cannot connect to database!";
                     97: 	system("echo 'Cannot connect to MySQL database!' |\
                     98:  mailto $emailto -s '$subj' > /dev/null");
                     99: 	exit 1;
1.31      harris41  100:     }
                    101:     else {
                    102: 	$dbh->disconnect;
                    103:     }
                    104: }
                    105: 
1.4       www       106: # --------------------------------------------- Check if other instance running
                    107: 
                    108: my $pidfile="$perlvar{'lonDaemons'}/logs/lonsql.pid";
                    109: 
                    110: if (-e $pidfile) {
                    111:    my $lfh=IO::File->new("$pidfile");
                    112:    my $pide=<$lfh>;
                    113:    chomp($pide);
                    114:    if (kill 0 => $pide) { die "already running"; }
                    115: }
1.1       harris41  116: 
                    117: # ------------------------------------------------------------- Read hosts file
1.2       harris41  118: $PREFORK=4; # number of children to maintain, at least four spare
1.1       harris41  119: 
                    120: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
                    121: 
                    122: while ($configline=<CONFIG>) {
                    123:     my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
                    124:     chomp($ip);
                    125: 
1.2       harris41  126:     $hostip{$ip}=$id;
1.1       harris41  127:     if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
                    128: 
1.2       harris41  129:     $PREFORK++;
1.1       harris41  130: }
                    131: close(CONFIG);
1.36      www       132: 
                    133: $PREFORK=int($PREFORK/4);
1.1       harris41  134: 
1.2       harris41  135: $unixsock = "mysqlsock";
                    136: my $localfile="$perlvar{'lonSockDir'}/$unixsock";
                    137: my $server;
                    138: unlink ($localfile);
                    139: unless ($server=IO::Socket::UNIX->new(Local    =>"$localfile",
                    140: 				  Type    => SOCK_STREAM,
                    141: 				  Listen => 10))
                    142: {
                    143:     print "in socket error:$@\n";
                    144: }
1.1       harris41  145: 
                    146: # -------------------------------------------------------- Routines for forking
                    147: # global variables
1.2       harris41  148: $MAX_CLIENTS_PER_CHILD  = 5;        # number of clients each child should process
1.1       harris41  149: %children               = ();       # keys are current child process IDs
1.2       harris41  150: $children               = 0;        # current number of children
1.1       harris41  151: 
                    152: sub REAPER {                        # takes care of dead children
                    153:     $SIG{CHLD} = \&REAPER;
                    154:     my $pid = wait;
1.2       harris41  155:     $children --;
                    156:     &logthis("Child $pid died");
1.1       harris41  157:     delete $children{$pid};
                    158: }
                    159: 
                    160: sub HUNTSMAN {                      # signal handler for SIGINT
                    161:     local($SIG{CHLD}) = 'IGNORE';   # we're going to kill our children
                    162:     kill 'INT' => keys %children;
                    163:     my $execdir=$perlvar{'lonDaemons'};
                    164:     unlink("$execdir/logs/lonsql.pid");
                    165:     &logthis("<font color=red>CRITICAL: Shutting down</font>");
1.2       harris41  166:     $unixsock = "mysqlsock";
                    167:     my $port="$perlvar{'lonSockDir'}/$unixsock";
                    168:     unlink(port);
1.1       harris41  169:     exit;                           # clean up with dignity
                    170: }
                    171: 
                    172: sub HUPSMAN {                      # signal handler for SIGHUP
                    173:     local($SIG{CHLD}) = 'IGNORE';  # we're going to kill our children
                    174:     kill 'INT' => keys %children;
                    175:     close($server);                # free up socket
                    176:     &logthis("<font color=red>CRITICAL: Restarting</font>");
                    177:     my $execdir=$perlvar{'lonDaemons'};
1.2       harris41  178:     $unixsock = "mysqlsock";
                    179:     my $port="$perlvar{'lonSockDir'}/$unixsock";
                    180:     unlink(port);
1.1       harris41  181:     exec("$execdir/lonsql");         # here we go again
                    182: }
                    183: 
                    184: sub logthis {
                    185:     my $message=shift;
                    186:     my $execdir=$perlvar{'lonDaemons'};
1.2       harris41  187:     my $fh=IO::File->new(">>$execdir/logs/lonsqlfinal.log");
1.1       harris41  188:     my $now=time;
                    189:     my $local=localtime($now);
                    190:     print $fh "$local ($$): $message\n";
                    191: }
1.45    ! www       192: 
        !           193: 
        !           194: 
        !           195: # -------------------------------------------- Return path to profile directory
        !           196: 
        !           197: sub propath {
        !           198:     my ($udom,$uname)=@_;
        !           199:     $udom=~s/\W//g;
        !           200:     $uname=~s/\W//g;
        !           201:     my $subdir=$uname.'__';
        !           202:     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
        !           203:     my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
        !           204:     return $proname;
        !           205: } 
        !           206: 
        !           207: # ------------------------------------------------------------------ Course log
        !           208: 
        !           209: sub courselog {
        !           210:     my ($path,$command)=@_;
        !           211:     return 'not_yet_implemented';
        !           212: }
        !           213: 
        !           214: # -------------------------------------------------------------------- User log
        !           215: 
        !           216: sub userlog {
        !           217:     my ($path,$command)=@_;
        !           218:     return 'not_yet_implemented';
        !           219: }
        !           220: 
        !           221: 
1.1       harris41  222: # ---------------------------------------------------- Fork once and dissociate
                    223: $fpid=fork;
                    224: exit if $fpid;
                    225: die "Couldn't fork: $!" unless defined ($fpid);
                    226: 
                    227: POSIX::setsid() or die "Can't start new session: $!";
                    228: 
                    229: # ------------------------------------------------------- Write our PID on disk
                    230: 
                    231: $execdir=$perlvar{'lonDaemons'};
                    232: open (PIDSAVE,">$execdir/logs/lonsql.pid");
                    233: print PIDSAVE "$$\n";
                    234: close(PIDSAVE);
                    235: &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
                    236: 
                    237: # ----------------------------- Ignore signals generated during initial startup
                    238: $SIG{HUP}=$SIG{USR1}='IGNORE';
1.2       harris41  239: # ------------------------------------------------------- Now we are on our own    
                    240: # Fork off our children.
                    241: for (1 .. $PREFORK) {
                    242:     make_new_child();
1.1       harris41  243: }
                    244: 
1.2       harris41  245: # Install signal handlers.
1.1       harris41  246: $SIG{CHLD} = \&REAPER;
                    247: $SIG{INT}  = $SIG{TERM} = \&HUNTSMAN;
                    248: $SIG{HUP}  = \&HUPSMAN;
                    249: 
                    250: # And maintain the population.
                    251: while (1) {
                    252:     sleep;                          # wait for a signal (i.e., child's death)
1.2       harris41  253:     for ($i = $children; $i < $PREFORK; $i++) {
                    254:         make_new_child();           # top up the child pool
1.1       harris41  255:     }
                    256: }
                    257: 
1.2       harris41  258: 
1.1       harris41  259: sub make_new_child {
                    260:     my $pid;
                    261:     my $sigset;
1.2       harris41  262:     
1.1       harris41  263:     # block signal for fork
                    264:     $sigset = POSIX::SigSet->new(SIGINT);
                    265:     sigprocmask(SIG_BLOCK, $sigset)
                    266:         or die "Can't block SIGINT for fork: $!\n";
                    267:     
1.2       harris41  268:     die "fork: $!" unless defined ($pid = fork);
                    269:     
1.1       harris41  270:     if ($pid) {
                    271:         # Parent records the child's birth and returns.
                    272:         sigprocmask(SIG_UNBLOCK, $sigset)
                    273:             or die "Can't unblock SIGINT for fork: $!\n";
                    274:         $children{$pid} = 1;
                    275:         $children++;
                    276:         return;
                    277:     } else {
1.2       harris41  278:         # Child can *not* return from this subroutine.
1.1       harris41  279:         $SIG{INT} = 'DEFAULT';      # make SIGINT kill us as it did before
                    280:     
                    281:         # unblock signals
                    282:         sigprocmask(SIG_UNBLOCK, $sigset)
                    283:             or die "Can't unblock SIGINT for fork: $!\n";
1.2       harris41  284: 	
                    285: 	
                    286:         #open database handle
                    287: 	# making dbh global to avoid garbage collector
1.1       harris41  288: 	unless (
1.31      harris41  289: 		$dbh = DBI->connect("DBI:mysql:loncapa","www",$perlvar{'lonSqlAccess'},{ RaiseError =>0,PrintError=>0})
1.1       harris41  290: 		) { 
1.30      harris41  291:   	            sleep(10+int(rand(20)));
1.1       harris41  292: 		    &logthis("<font color=blue>WARNING: Couldn't connect to database  ($st secs): $@</font>");
1.2       harris41  293: 		    print "database handle error\n";
                    294: 		    exit;
                    295: 
                    296: 	  };
                    297: 	# make sure that a database disconnection occurs with ending kill signals
                    298: 	$SIG{TERM}=$SIG{INT}=$SIG{QUIT}=$SIG{__DIE__}=\&DISCONNECT;
                    299: 
1.1       harris41  300:         # handle connections until we've reached $MAX_CLIENTS_PER_CHILD
                    301:         for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
                    302:             $client = $server->accept()     or last;
1.2       harris41  303:             
                    304:             # do something with the connection
1.1       harris41  305: 	    $run = $run+1;
1.2       harris41  306: 	    my $userinput = <$client>;
                    307: 	    chomp($userinput);
                    308: 	    	    
1.45    ! www       309: 	    my ($conserver,$query,
        !           310: 		$arg1,$arg2,$arg3)=split(/&/,$userinput);
        !           311: 	    my $query=unescape($query);
1.2       harris41  312: 
                    313:             #send query id which is pid_unixdatetime_runningcounter
                    314: 	    $queryid = $thisserver;
                    315: 	    $queryid .="_".($$)."_";
                    316: 	    $queryid .= time."_";
                    317: 	    $queryid .= $run;
                    318: 	    print $client "$queryid\n";
                    319: 	    
1.25      harris41  320: 	    &logthis("QUERY: $query");
                    321: 	    sleep 1;
1.44      www       322: 
1.45    ! www       323:             my $result='';
        !           324: 
1.44      www       325: # ---------- At this point, query is received, query-ID assigned and sent back 
                    326: # $query eq 'logquery' will mean that this is a query against log-files
                    327: 
1.45    ! www       328: 
        !           329: 	   if (($query eq 'userlog') || ($query eq 'courselog')) {
        !           330: # ----------------------------------------------------- beginning of log query
        !           331: #
        !           332: # this goes against a user's log file
        !           333: #
        !           334: 	       my $udom=&unescape($arg1);
        !           335: 	       my $uname=&unescape($arg2);
        !           336:                my $command=&unescape($arg3);
        !           337:                my $path=&propath($udom,$uname);
        !           338:                if (-e "$path/activity.log") {
        !           339: 		   if ($query eq 'userlog') {
        !           340:                        $result=&userlog($path,$command);
        !           341:                    } else {
        !           342:                        $result=&courselog($path,$command);
        !           343:                    }
        !           344:                } else {
        !           345: 		   &logthis('Unable to do log query: '.$uname.'@'.$udom);
        !           346: 	           $result='no_such_file';
        !           347: 	       }
        !           348: # ------------------------------------------------------------ end of log query
        !           349:           } else {
1.44      www       350: # -------------------------------------------------------- This is an sql query
1.45    ! www       351: 	    my $custom=unescape($arg1);
        !           352: 	    my $customshow=unescape($arg2);
1.2       harris41  353:             #prepare and execute the query
1.3       harris41  354: 	    my $sth = $dbh->prepare($query);
1.45    ! www       355: 
1.20      harris41  356: 	    my @files;
1.24      harris41  357: 	    my $subsetflag=0;
1.26      harris41  358: 	    if ($query) {
                    359: 		unless ($sth->execute())
                    360: 		{
                    361: 		    &logthis("<font color=blue>WARNING: Could not retrieve from database: $@</font>");
                    362: 		    $result="";
                    363: 		}
                    364: 		else {
                    365: 		    my $r1=$sth->fetchall_arrayref;
                    366: 		    my @r2;
1.41      harris41  367: 		    foreach (@$r1) {my $a=$_; 
1.26      harris41  368: 			 my @b=map {escape($_)} @$a;
                    369: 			 push @files,@{$a}[3];
                    370: 			 push @r2,join(",", @b)
1.41      harris41  371: 			 }
1.26      harris41  372: 		    $result=join("&",@r2);
                    373: 		}
1.3       harris41  374: 	    }
1.7       harris41  375: 	    # do custom metadata searching here and build into result
1.28      harris41  376: 	    if ($custom or $customshow) {
1.9       harris41  377: 		&logthis("am going to do custom query for $custom");
1.26      harris41  378: 		if ($query) {
1.23      harris41  379: 		    @metalist=map {$perlvar{'lonDocRoot'}.$_.'.meta'} @files;
1.20      harris41  380: 		}
                    381: 		else {
                    382: 		    @metalist=(); pop @metalist;
1.34      harris41  383: 		    opendir(RESOURCES,"$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}");
                    384: 		    my @homeusers=grep
                    385: 		          {&ishome("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$_")}
                    386: 		          grep {!/^\.\.?$/} readdir(RESOURCES);
                    387: 		    closedir RESOURCES;
                    388: 		    foreach my $user (@homeusers) {
                    389: 			&find("$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}/$user");
                    390: 		    }
1.20      harris41  391: 		}
1.23      harris41  392: #		&logthis("FILELIST:" . join(":::",@metalist));
1.10      harris41  393: 		# if file is indicated in sql database and
                    394: 		# not part of sql-relevant query, do not pattern match.
                    395: 		# if file is not in sql database, output error.
                    396: 		# if file is indicated in sql database and is
                    397: 		# part of query result list, then do the pattern match.
1.12      harris41  398: 		my $customresult='';
1.26      harris41  399: 		my @r2;
1.11      harris41  400: 		foreach my $m (@metalist) {
                    401: 		    my $fh=IO::File->new($m);
                    402: 		    my @lines=<$fh>;
                    403: 		    my $stuff=join('',@lines);
                    404: 		    if ($stuff=~/$custom/s) {
1.18      harris41  405: 			foreach my $f ('abstract','author','copyright',
                    406: 				       'creationdate','keywords','language',
                    407: 				       'lastrevisiondate','mime','notes',
                    408: 				       'owner','subject','title') {
1.37      harris41  409: 			    $stuff=~s/\n?\<$f[^\>]*\>.*?<\/$f[^\>]*\>\n?//s;
1.18      harris41  410: 			}
1.19      harris41  411: 			my $m2=$m; my $docroot=$perlvar{'lonDocRoot'};
1.26      harris41  412: 			$m2=~s/^$docroot//;
                    413: 			$m2=~s/\.meta$//;
                    414: 			unless ($query) {
1.35      harris41  415: 			    my $q2="select * from metadata where url like binary '$m2'";
1.27      harris41  416: 			    my $sth = $dbh->prepare($q2);
1.26      harris41  417: 			    $sth->execute();
                    418: 			    my $r1=$sth->fetchall_arrayref;
1.41      harris41  419: 			    foreach (@$r1) {my $a=$_; 
1.26      harris41  420: 				 my @b=map {escape($_)} @$a;
                    421: 				 push @files,@{$a}[3];
                    422: 				 push @r2,join(",", @b)
1.41      harris41  423: 				 }
1.26      harris41  424: 			}
1.20      harris41  425: #			&logthis("found: $stuff");
1.19      harris41  426: 			$customresult.='&custom='.escape($m2).','.escape($stuff);
1.11      harris41  427: 		    }
                    428: 		}
1.26      harris41  429: 		$result=join("&",@r2) unless $query;
1.17      harris41  430: 		$result.=$customresult;
1.9       harris41  431: 	    }
1.44      www       432: # ------------------------------------------------------------ end of sql query
1.45    ! www       433: 	  }
1.44      www       434: 	    # reply with result, append \n unless already there
1.45    ! www       435: 
1.44      www       436: 	    $result.="\n" unless ($result=~/\n$/);
1.17      harris41  437:             &reply("queryreply:$queryid:$result",$conserver);
1.2       harris41  438: 
1.1       harris41  439:         }
                    440:     
                    441:         # tidy up gracefully and finish
1.2       harris41  442: 	
                    443:         #close the database handle
                    444: 	$dbh->disconnect
                    445: 	   or &logthis("<font color=blue>WARNING: Couldn't disconnect from database  $DBI::errstr ($st secs): $@</font>");
1.1       harris41  446:     
                    447:         # this exit is VERY important, otherwise the child will become
                    448:         # a producer of more and more children, forking yourself into
                    449:         # process death.
                    450:         exit;
                    451:     }
1.2       harris41  452: }
1.1       harris41  453: 
1.2       harris41  454: sub DISCONNECT {
                    455:     $dbh->disconnect or 
                    456:     &logthis("<font color=blue>WARNING: Couldn't disconnect from database  $DBI::errstr ($st secs): $@</font>");
                    457:     exit;
                    458: }
1.1       harris41  459: 
1.2       harris41  460: # -------------------------------------------------- Non-critical communication
1.1       harris41  461: 
1.2       harris41  462: sub subreply {
                    463:     my ($cmd,$server)=@_;
                    464:     my $peerfile="$perlvar{'lonSockDir'}/$server";
                    465:     my $sclient=IO::Socket::UNIX->new(Peer    =>"$peerfile",
                    466:                                       Type    => SOCK_STREAM,
                    467:                                       Timeout => 10)
                    468:        or return "con_lost";
                    469:     print $sclient "$cmd\n";
                    470:     my $answer=<$sclient>;
                    471:     chomp($answer);
                    472:     if (!$answer) { $answer="con_lost"; }
                    473:     return $answer;
                    474: }
1.1       harris41  475: 
1.2       harris41  476: sub reply {
                    477:   my ($cmd,$server)=@_;
                    478:   my $answer;
                    479:   if ($server ne $perlvar{'lonHostID'}) { 
                    480:     $answer=subreply($cmd,$server);
                    481:     if ($answer eq 'con_lost') {
                    482: 	$answer=subreply("ping",$server);
                    483:         $answer=subreply($cmd,$server);
                    484:     }
                    485:   } else {
                    486:     $answer='self_reply';
1.33      harris41  487:     $answer=subreply($cmd,$server);
1.2       harris41  488:   } 
                    489:   return $answer;
                    490: }
1.1       harris41  491: 
1.3       harris41  492: # -------------------------------------------------------- Escape Special Chars
                    493: 
                    494: sub escape {
                    495:     my $str=shift;
                    496:     $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
                    497:     return $str;
                    498: }
                    499: 
                    500: # ----------------------------------------------------- Un-Escape Special Chars
                    501: 
                    502: sub unescape {
                    503:     my $str=shift;
                    504:     $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
                    505:     return $str;
                    506: }
1.34      harris41  507: 
                    508: # --------------------------------------- Is this the home server of an author?
                    509: # (copied from lond, modification of the return value)
                    510: sub ishome {
                    511:     my $author=shift;
                    512:     $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
                    513:     my ($udom,$uname)=split(/\//,$author);
                    514:     my $proname=propath($udom,$uname);
                    515:     if (-e $proname) {
                    516: 	return 1;
                    517:     } else {
                    518:         return 0;
                    519:     }
                    520: }
                    521: 
                    522: # -------------------------------------------- Return path to profile directory
                    523: # (copied from lond)
                    524: sub propath {
                    525:     my ($udom,$uname)=@_;
                    526:     $udom=~s/\W//g;
                    527:     $uname=~s/\W//g;
                    528:     my $subdir=$uname.'__';
                    529:     $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
                    530:     my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
                    531:     return $proname;
                    532: } 
1.40      harris41  533: 
                    534: # ----------------------------------- POD (plain old documentation, CPAN style)
                    535: 
                    536: =head1 NAME
                    537: 
                    538: lonsql - LON TCP-MySQL-Server Daemon for handling database requests.
                    539: 
                    540: =head1 SYNOPSIS
                    541: 
                    542: This script should be run as user=www.  The following is an example invocation
                    543: from the loncron script.  Note that a lonsql.pid file contains the pid of
                    544: the parent process.
                    545: 
                    546:     if (-e $lonsqlfile) {
                    547: 	my $lfh=IO::File->new("$lonsqlfile");
                    548: 	my $lonsqlpid=<$lfh>;
                    549: 	chomp($lonsqlpid);
                    550: 	if (kill 0 => $lonsqlpid) {
                    551: 	    print $fh "<h3>lonsql at pid $lonsqlpid responding</h3>";
                    552: 	    $restartflag=0;
                    553: 	} else {
                    554: 	    $errors++; $errors++;
                    555: 	    print $fh "<h3>lonsql at pid $lonsqlpid not responding</h3>";
                    556: 		$restartflag=1;
                    557: 	print $fh 
                    558: 	    "<h3>Decided to clean up stale .pid file and restart lonsql</h3>";
                    559: 	}
                    560:     }
                    561:     if ($restartflag==1) {
                    562: 	$errors++;
                    563: 	         print $fh '<br><font color="red">Killall lonsql: '.
                    564:                     system('killall lonsql').' - ';
                    565:                     sleep 60;
                    566:                     print $fh unlink($lonsqlfile).' - '.
                    567:                               system('killall -9 lonsql').
                    568:                     '</font><br>';
                    569: 	print $fh "<h3>lonsql not running, trying to start</h3>";
                    570: 	system(
                    571:  "$perlvar{'lonDaemons'}/lonsql 2>>$perlvar{'lonDaemons'}/logs/lonsql_errors");
                    572: 	sleep 10;
                    573: 
                    574: =head1 DESCRIPTION
                    575: 
1.41      harris41  576: Not yet written.
1.40      harris41  577: 
                    578: =head1 README
                    579: 
1.41      harris41  580: Not yet written.
1.40      harris41  581: 
                    582: =head1 PREREQUISITES
                    583: 
                    584: IO::Socket
                    585: Symbol
                    586: POSIX
                    587: IO::Select
                    588: IO::File
                    589: Socket
                    590: Fcntl
                    591: Tie::RefHash
                    592: DBI
                    593: 
                    594: =head1 COREQUISITES
                    595: 
                    596: =head1 OSNAMES
                    597: 
                    598: linux
                    599: 
                    600: =head1 SCRIPT CATEGORIES
                    601: 
                    602: Server/Process
                    603: 
                    604: =cut

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