Annotation of loncom/lonsql, revision 1.53
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.53 ! harris41 6: # $Id: lonsql,v 1.52 2002/08/13 19:40:57 matthew 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.51 matthew 30:
31: =pod
32:
33: =head1 NAME
34:
35: lonsql - LON TCP-MySQL-Server Daemon for handling database requests.
36:
37: =head1 SYNOPSIS
38:
39: This script should be run as user=www.
40: Note that a lonsql.pid file contains the pid of the parent process.
41:
42: =head1 DESCRIPTION
43:
44: lonsql is many things to many people. To me, it is a source file in need
45: of documentation.
46:
47: =head1 Internals
48:
49: =over 4
50:
51: =cut
52:
53: use strict;
1.36 www 54:
1.42 harris41 55: use lib '/home/httpd/lib/perl/';
56: use LONCAPA::Configuration;
57:
1.2 harris41 58: use IO::Socket;
59: use Symbol;
1.1 harris41 60: use POSIX;
61: use IO::Select;
62: use IO::File;
63: use Socket;
64: use Fcntl;
65: use Tie::RefHash;
66: use DBI;
1.51 matthew 67: use File::Find;
68:
69: ########################################################
70: ########################################################
71:
72: =pod
73:
74: =item Global Variables
75:
76: =over 4
77:
78: =item dbh
79:
80: =back
81:
82: =cut
83:
84: ########################################################
85: ########################################################
86: my $dbh;
87:
88: ########################################################
89: ########################################################
90:
91: =pod
92:
93: =item Variables required for forking
1.1 harris41 94:
1.51 matthew 95: =over 4
96:
97: =item $MAX_CLIENTS_PER_CHILD
98:
99: The number of clients each child should process.
100:
101: =item %children
102:
103: The keys to %children are the current child process IDs
104:
105: =item $children
106:
107: The current number of children
108:
109: =back
110:
111: =cut
1.9 harris41 112:
1.51 matthew 113: ########################################################
114: ########################################################
115: my $MAX_CLIENTS_PER_CHILD = 5; # number of clients each child should process
116: my %children = (); # keys are current child process IDs
117: my $children = 0; # current number of children
118:
119: ###################################################################
120: ###################################################################
121:
122: =pod
123:
124: =item Main body of code.
125:
126: =over 4
1.45 www 127:
1.51 matthew 128: =item Read data from loncapa_apache.conf and loncapa.conf.
129:
130: =item Ensure we can access the database.
131:
132: =item Determine if there are other instances of lonsql running.
133:
134: =item Read the hosts file.
135:
136: =item Create a socket for lonsql.
137:
138: =item Fork once and dissociate from parent.
139:
140: =item Write PID to disk.
141:
142: =item Prefork children and maintain the population of children.
143:
144: =back
145:
146: =cut
147:
148: ###################################################################
149: ###################################################################
150: my $childmaxattempts=10;
151: my $run =0; # running counter to generate the query-id
152: #
153: # Read loncapa_apache.conf and loncapa.conf
154: #
1.53 ! harris41 155: my $perlvarref=LONCAPA::Configuration::read_conf('loncapa.conf');
1.51 matthew 156: my %perlvar=%{$perlvarref};
157: #
158: # Make sure that database can be accessed
159: #
160: my $dbh;
161: unless ($dbh = DBI->connect("DBI:mysql:loncapa","www",
162: $perlvar{'lonSqlAccess'},
163: { RaiseError =>0,PrintError=>0})) {
164: print "Cannot connect to database!\n";
165: my $emailto="$perlvar{'lonAdmEMail'},$perlvar{'lonSysEMail'}";
166: my $subj="LON: $perlvar{'lonHostID'} Cannot connect to database!";
167: system("echo 'Cannot connect to MySQL database!' |".
168: " mailto $emailto -s '$subj' > /dev/null");
169: exit 1;
170: } else {
171: $dbh->disconnect;
172: }
1.52 matthew 173:
1.51 matthew 174: #
175: # Check if other instance running
176: #
177: my $pidfile="$perlvar{'lonDaemons'}/logs/lonsql.pid";
178: if (-e $pidfile) {
179: my $lfh=IO::File->new("$pidfile");
180: my $pide=<$lfh>;
181: chomp($pide);
182: if (kill 0 => $pide) { die "already running"; }
183: }
1.52 matthew 184:
1.49 www 185: #
1.51 matthew 186: # Read hosts file
1.49 www 187: #
1.51 matthew 188: my %hostip;
189: my $thisserver;
190: my $PREFORK=4; # number of children to maintain, at least four spare
191: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
192: while (my $configline=<CONFIG>) {
193: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
194: chomp($ip);
195: $hostip{$ip}=$id;
196: $thisserver=$name if ($id eq $perlvar{'lonHostID'});
197: $PREFORK++;
1.45 www 198: }
1.51 matthew 199: close(CONFIG);
200: #
201: $PREFORK=int($PREFORK/4);
1.52 matthew 202:
1.51 matthew 203: #
204: # Create a socket to talk to lond
205: #
206: my $unixsock = "mysqlsock";
207: my $localfile="$perlvar{'lonSockDir'}/$unixsock";
208: my $server;
209: unlink ($localfile);
210: unless ($server=IO::Socket::UNIX->new(Local =>"$localfile",
211: Type => SOCK_STREAM,
212: Listen => 10)) {
213: print "in socket error:$@\n";
1.45 www 214: }
1.52 matthew 215:
1.51 matthew 216: #
217: # Fork once and dissociate
1.52 matthew 218: #
1.51 matthew 219: my $fpid=fork;
1.1 harris41 220: exit if $fpid;
221: die "Couldn't fork: $!" unless defined ($fpid);
222: POSIX::setsid() or die "Can't start new session: $!";
1.52 matthew 223:
1.51 matthew 224: #
225: # Write our PID on disk
226: my $execdir=$perlvar{'lonDaemons'};
1.1 harris41 227: open (PIDSAVE,">$execdir/logs/lonsql.pid");
228: print PIDSAVE "$$\n";
229: close(PIDSAVE);
230: &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
1.52 matthew 231:
1.51 matthew 232: #
233: # Ignore signals generated during initial startup
1.1 harris41 234: $SIG{HUP}=$SIG{USR1}='IGNORE';
1.51 matthew 235: # Now we are on our own
236: # Fork off our children.
1.2 harris41 237: for (1 .. $PREFORK) {
238: make_new_child();
1.1 harris41 239: }
1.52 matthew 240:
1.51 matthew 241: #
1.2 harris41 242: # Install signal handlers.
1.1 harris41 243: $SIG{CHLD} = \&REAPER;
244: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
245: $SIG{HUP} = \&HUPSMAN;
1.52 matthew 246:
1.51 matthew 247: #
1.1 harris41 248: # And maintain the population.
249: while (1) {
250: sleep; # wait for a signal (i.e., child's death)
1.51 matthew 251: for (my $i = $children; $i < $PREFORK; $i++) {
1.2 harris41 252: make_new_child(); # top up the child pool
1.1 harris41 253: }
254: }
255:
1.51 matthew 256: ########################################################
257: ########################################################
258:
259: =pod
260:
261: =item &make_new_child
262:
263: Inputs: None
264:
265: Returns: None
266:
267: =cut
1.2 harris41 268:
1.51 matthew 269: ########################################################
270: ########################################################
1.1 harris41 271: sub make_new_child {
272: my $pid;
273: my $sigset;
1.51 matthew 274: #
1.1 harris41 275: # block signal for fork
276: $sigset = POSIX::SigSet->new(SIGINT);
277: sigprocmask(SIG_BLOCK, $sigset)
278: or die "Can't block SIGINT for fork: $!\n";
1.51 matthew 279: #
1.2 harris41 280: die "fork: $!" unless defined ($pid = fork);
1.51 matthew 281: #
1.1 harris41 282: if ($pid) {
283: # Parent records the child's birth and returns.
284: sigprocmask(SIG_UNBLOCK, $sigset)
285: or die "Can't unblock SIGINT for fork: $!\n";
286: $children{$pid} = 1;
287: $children++;
288: return;
289: } else {
1.2 harris41 290: # Child can *not* return from this subroutine.
1.1 harris41 291: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
292: # unblock signals
293: sigprocmask(SIG_UNBLOCK, $sigset)
294: or die "Can't unblock SIGINT for fork: $!\n";
1.2 harris41 295: #open database handle
296: # making dbh global to avoid garbage collector
1.51 matthew 297: unless ($dbh = DBI->connect("DBI:mysql:loncapa","www",
298: $perlvar{'lonSqlAccess'},
299: { RaiseError =>0,PrintError=>0})) {
300: sleep(10+int(rand(20)));
301: &logthis("<font color=blue>WARNING: Couldn't connect to database".
302: ": $@</font>");
303: # "($st secs): $@</font>");
304: print "database handle error\n";
305: exit;
306: }
307: # make sure that a database disconnection occurs with
308: # ending kill signals
1.2 harris41 309: $SIG{TERM}=$SIG{INT}=$SIG{QUIT}=$SIG{__DIE__}=\&DISCONNECT;
1.1 harris41 310: # handle connections until we've reached $MAX_CLIENTS_PER_CHILD
1.51 matthew 311: for (my $i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
312: my $client = $server->accept() or last;
1.2 harris41 313: # do something with the connection
1.1 harris41 314: $run = $run+1;
1.2 harris41 315: my $userinput = <$client>;
316: chomp($userinput);
1.51 matthew 317: #
1.45 www 318: my ($conserver,$query,
319: $arg1,$arg2,$arg3)=split(/&/,$userinput);
320: my $query=unescape($query);
1.51 matthew 321: #
1.2 harris41 322: #send query id which is pid_unixdatetime_runningcounter
1.51 matthew 323: my $queryid = $thisserver;
1.2 harris41 324: $queryid .="_".($$)."_";
325: $queryid .= time."_";
326: $queryid .= $run;
327: print $client "$queryid\n";
1.51 matthew 328: #
1.47 www 329: &logthis("QUERY: $query - $arg1 - $arg2 - $arg3");
1.25 harris41 330: sleep 1;
1.51 matthew 331: #
1.45 www 332: my $result='';
1.51 matthew 333: #
334: # At this point, query is received, query-ID assigned and sent
335: # back, $query eq 'logquery' will mean that this is a query
336: # against log-files
337: if (($query eq 'userlog') || ($query eq 'courselog')) {
338: # beginning of log query
339: my $udom = &unescape($arg1);
340: my $uname = &unescape($arg2);
341: my $command = &unescape($arg3);
342: my $path = &propath($udom,$uname);
343: if (-e "$path/activity.log") {
344: if ($query eq 'userlog') {
345: $result=&userlog($path,$command);
346: } else {
347: $result=&courselog($path,$command);
348: }
349: } else {
350: &logthis('Unable to do log query: '.$uname.'@'.$udom);
351: $result='no_such_file';
352: }
353: # end of log query
354: } else {
355: # Do an sql query
356: $result = &do_sql_query($query,$arg1,$arg2);
357: }
1.50 matthew 358: # result does not need to be escaped because it has already been
359: # escaped.
360: #$result=&escape($result);
1.51 matthew 361: # reply with result, append \n unless already there
1.44 www 362: $result.="\n" unless ($result=~/\n$/);
1.17 harris41 363: &reply("queryreply:$queryid:$result",$conserver);
1.1 harris41 364: }
365: # tidy up gracefully and finish
1.51 matthew 366: #
367: # close the database handle
1.2 harris41 368: $dbh->disconnect
1.51 matthew 369: or &logthis("<font color=blue>WARNING: Couldn't disconnect".
370: " from database $DBI::errstr : $@</font>");
1.1 harris41 371: # this exit is VERY important, otherwise the child will become
372: # a producer of more and more children, forking yourself into
373: # process death.
374: exit;
375: }
1.2 harris41 376: }
1.1 harris41 377:
1.51 matthew 378: ########################################################
379: ########################################################
380:
381: =pod
382:
383: =item &do_sql_query
384:
385: Runs an sql metadata table query.
386:
387: Inputs: $query, $custom, $customshow
388:
389: Returns: A string containing escaped results.
390:
391: =cut
392:
393: ########################################################
394: ########################################################
395: {
396: my @metalist;
397:
398: sub process_file {
399: if ( -e $_ && # file exists
400: -f $_ && # and is a normal file
401: /\.meta$/ && # ends in meta
402: ! /^.+\.\d+\.[^\.]+\.meta$/ # is not a previous version
403: ) {
404: push(@metalist,$File::Find::name);
405: }
406: }
407:
408: sub do_sql_query {
409: my ($query,$custom,$customshow) = @_;
410: $custom = &unescape($custom);
411: $customshow = &unescape($customshow);
412: #
413: @metalist = ();
414: #
415: my $result = '';
416: my @results = ();
417: my @files;
418: my $subsetflag=0;
419: #
420: if ($query) {
421: #prepare and execute the query
422: my $sth = $dbh->prepare($query);
423: unless ($sth->execute()) {
424: &logthis("<font color=blue>WARNING: ".
425: "Could not retrieve from database: $@</font>");
426: } else {
427: my $aref=$sth->fetchall_arrayref;
428: foreach my $row (@$aref) {
429: push @files,@{$row}[3] if ($custom or $customshow);
430: my @b=map { &escape($_); } @$row;
431: push @results,join(",", @b);
432: # Build up the @files array with the LON-CAPA urls
433: # of the resources.
434: }
435: }
436: }
437: # do custom metadata searching here and build into result
438: return join("&",@results) if (! ($custom or $customshow));
439: # Only get here if there is a custom query or custom show request
440: &logthis("Doing custom query for $custom");
441: if ($query) {
442: @metalist=map {
443: $perlvar{'lonDocRoot'}.$_.'.meta';
444: } @files;
445: } else {
446: my $dir = "$perlvar{'lonDocRoot'}/res/$perlvar{'lonDefDomain'}";
447: @metalist=();
448: opendir(RESOURCES,$dir);
449: my @homeusers=grep {
450: &ishome($dir.'/'.$_);
451: } grep {!/^\.\.?$/} readdir(RESOURCES);
452: closedir RESOURCES;
453: # Define the
454: foreach my $user (@homeusers) {
455: find (\&process_file,$dir.'/'.$user);
456: }
457: }
458: # if file is indicated in sql database and
459: # not part of sql-relevant query, do not pattern match.
460: #
461: # if file is not in sql database, output error.
462: #
463: # if file is indicated in sql database and is
464: # part of query result list, then do the pattern match.
465: my $customresult='';
466: my @results;
467: foreach my $metafile (@metalist) {
468: my $fh=IO::File->new($metafile);
469: my @lines=<$fh>;
470: my $stuff=join('',@lines);
471: if ($stuff=~/$custom/s) {
472: foreach my $f ('abstract','author','copyright',
473: 'creationdate','keywords','language',
474: 'lastrevisiondate','mime','notes',
475: 'owner','subject','title') {
476: $stuff=~s/\n?\<$f[^\>]*\>.*?<\/$f[^\>]*\>\n?//s;
477: }
478: my $mfile=$metafile;
479: my $docroot=$perlvar{'lonDocRoot'};
480: $mfile=~s/^$docroot//;
481: $mfile=~s/\.meta$//;
482: unless ($query) {
483: my $q2="SELECT * FROM metadata WHERE url ".
484: " LIKE BINARY '?'";
485: my $sth = $dbh->prepare($q2);
486: $sth->execute($mfile);
487: my $aref=$sth->fetchall_arrayref;
488: foreach my $a (@$aref) {
489: my @b=map { &escape($_)} @$a;
490: push @results,join(",", @b);
491: }
492: }
493: # &logthis("found: $stuff");
494: $customresult.='&custom='.&escape($mfile).','.
495: escape($stuff);
496: }
497: }
498: $result=join("&",@results) unless $query;
499: $result.=$customresult;
500: #
501: return $result;
502: } # End of &do_sql_query
503:
504: } # End of scoping curly braces for &process_file and &do_sql_query
505: ########################################################
506: ########################################################
507:
508: =pod
509:
510: =item &logthis
511:
512: Inputs: $message, the message to log
513:
514: Returns: nothing
515:
516: Writes $message to the logfile.
517:
518: =cut
519:
520: ########################################################
521: ########################################################
522: sub logthis {
523: my $message=shift;
524: my $execdir=$perlvar{'lonDaemons'};
1.52 matthew 525: my $fh=IO::File->new(">>$execdir/logs/lonsql.log");
1.51 matthew 526: my $now=time;
527: my $local=localtime($now);
528: print $fh "$local ($$): $message\n";
1.2 harris41 529: }
1.1 harris41 530:
1.2 harris41 531: # -------------------------------------------------- Non-critical communication
1.1 harris41 532:
1.51 matthew 533: ########################################################
534: ########################################################
535:
536: =pod
537:
538: =item &subreply
539:
540: Sends a command to a server. Called only by &reply.
541:
542: Inputs: $cmd,$server
543:
544: Returns: The results of the message or 'con_lost' on error.
545:
546: =cut
547:
548: ########################################################
549: ########################################################
1.2 harris41 550: sub subreply {
551: my ($cmd,$server)=@_;
552: my $peerfile="$perlvar{'lonSockDir'}/$server";
553: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
554: Type => SOCK_STREAM,
555: Timeout => 10)
556: or return "con_lost";
557: print $sclient "$cmd\n";
558: my $answer=<$sclient>;
559: chomp($answer);
1.51 matthew 560: $answer="con_lost" if (!$answer);
1.2 harris41 561: return $answer;
562: }
1.1 harris41 563:
1.51 matthew 564: ########################################################
565: ########################################################
566:
567: =pod
568:
569: =item &reply
570:
571: Sends a command to a server.
572:
573: Inputs: $cmd,$server
574:
575: Returns: The results of the message or 'con_lost' on error.
576:
577: =cut
578:
579: ########################################################
580: ########################################################
1.2 harris41 581: sub reply {
582: my ($cmd,$server)=@_;
583: my $answer;
584: if ($server ne $perlvar{'lonHostID'}) {
585: $answer=subreply($cmd,$server);
586: if ($answer eq 'con_lost') {
587: $answer=subreply("ping",$server);
588: $answer=subreply($cmd,$server);
589: }
590: } else {
591: $answer='self_reply';
1.33 harris41 592: $answer=subreply($cmd,$server);
1.2 harris41 593: }
594: return $answer;
595: }
1.1 harris41 596:
1.51 matthew 597: ########################################################
598: ########################################################
599:
600: =pod
601:
602: =item &escape
603:
604: Escape special characters in a string.
1.3 harris41 605:
1.51 matthew 606: Inputs: string to escape
607:
608: Returns: The input string with special characters escaped.
609:
610: =cut
611:
612: ########################################################
613: ########################################################
1.3 harris41 614: sub escape {
615: my $str=shift;
616: $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
617: return $str;
618: }
619:
1.51 matthew 620: ########################################################
621: ########################################################
622:
623: =pod
624:
625: =item &unescape
626:
627: Unescape special characters in a string.
1.3 harris41 628:
1.51 matthew 629: Inputs: string to unescape
630:
631: Returns: The input string with special characters unescaped.
632:
633: =cut
634:
635: ########################################################
636: ########################################################
1.3 harris41 637: sub unescape {
638: my $str=shift;
639: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
640: return $str;
641: }
1.34 harris41 642:
1.51 matthew 643: ########################################################
644: ########################################################
645:
646: =pod
647:
648: =item &ishome
649:
650: Determine if the current machine is the home server for a user.
651: The determination is made by checking the filesystem for the users information.
652:
653: Inputs: $author
654:
655: Returns: 0 - this is not the authors home server, 1 - this is.
656:
657: =cut
658:
659: ########################################################
660: ########################################################
1.34 harris41 661: sub ishome {
662: my $author=shift;
663: $author=~s/\/home\/httpd\/html\/res\/([^\/]*)\/([^\/]*).*/$1\/$2/;
664: my ($udom,$uname)=split(/\//,$author);
665: my $proname=propath($udom,$uname);
666: if (-e $proname) {
667: return 1;
668: } else {
669: return 0;
670: }
671: }
672:
1.51 matthew 673: ########################################################
674: ########################################################
675:
676: =pod
677:
678: =item &propath
679:
680: Inputs: user name, user domain
681:
682: Returns: The full path to the users directory.
683:
684: =cut
685:
686: ########################################################
687: ########################################################
1.34 harris41 688: sub propath {
689: my ($udom,$uname)=@_;
690: $udom=~s/\W//g;
691: $uname=~s/\W//g;
692: my $subdir=$uname.'__';
693: $subdir =~ s/(.)(.)(.).*/$1\/$2\/$3/;
694: my $proname="$perlvar{'lonUsersDir'}/$udom/$subdir/$uname";
695: return $proname;
696: }
1.40 harris41 697:
1.51 matthew 698: ########################################################
699: ########################################################
700:
701: =pod
702:
703: =item &courselog
704:
705: Inputs: $path, $command
706:
707: Returns: unescaped string of values.
708:
709: =cut
710:
711: ########################################################
712: ########################################################
713: sub courselog {
714: my ($path,$command)=@_;
715: my %filters=();
716: foreach (split(/\:/,&unescape($command))) {
717: my ($name,$value)=split(/\=/,$_);
718: $filters{$name}=$value;
719: }
720: my @results=();
721: open(IN,$path.'/activity.log') or return ('file_error');
722: while (my $line=<IN>) {
723: chomp($line);
724: my ($timestamp,$host,$log)=split(/\:/,$line);
725: #
726: # $log has the actual log entries; currently still escaped, and
727: # %26(timestamp)%3a(url)%3a(user)%3a(domain)
728: # then additionally
729: # %3aPOST%3a(name)%3d(value)%3a(name)%3d(value)
730: # or
731: # %3aCSTORE%3a(name)%3d(value)%26(name)%3d(value)
732: #
733: # get delimiter between timestamped entries to be &&&
734: $log=~s/\%26(\d+)\%3a/\&\&\&$1\%3a/g;
735: # now go over all log entries
736: foreach (split(/\&\&\&/,&unescape($log))) {
737: my ($time,$res,$uname,$udom,$action,@values)=split(/\:/,$_);
738: my $values=&unescape(join(':',@values));
739: $values=~s/\&/\:/g;
740: $res=&unescape($res);
741: my $include=1;
742: if (($filters{'username'}) && ($uname ne $filters{'username'}))
743: { $include=0; }
744: if (($filters{'domain'}) && ($udom ne $filters{'domain'}))
745: { $include=0; }
746: if (($filters{'url'}) && ($res!~/$filters{'url'}/))
747: { $include=0; }
748: if (($filters{'start'}) && ($time<$filters{'start'}))
749: { $include=0; }
750: if (($filters{'end'}) && ($time>$filters{'end'}))
751: { $include=0; }
752: if (($filters{'action'} eq 'view') && ($action))
753: { $include=0; }
754: if (($filters{'action'} eq 'submit') && ($action ne 'POST'))
755: { $include=0; }
756: if (($filters{'action'} eq 'grade') && ($action ne 'CSTORE'))
757: { $include=0; }
758: if ($include) {
759: push(@results,($time<1000000000?'0':'').$time.':'.$res.':'.
760: $uname.':'.$udom.':'.
761: $action.':'.$values);
762: }
763: }
764: }
765: close IN;
766: return join('&',sort(@results));
767: }
768:
769: ########################################################
770: ########################################################
771:
772: =pod
773:
774: =item &userlog
775:
776: Inputs: $path, $command
777:
778: Returns: unescaped string of values.
1.40 harris41 779:
1.51 matthew 780: =cut
1.40 harris41 781:
1.51 matthew 782: ########################################################
783: ########################################################
784: sub userlog {
785: my ($path,$command)=@_;
786: my %filters=();
787: foreach (split(/\:/,&unescape($command))) {
788: my ($name,$value)=split(/\=/,$_);
789: $filters{$name}=$value;
790: }
791: my @results=();
792: open(IN,$path.'/activity.log') or return ('file_error');
793: while (my $line=<IN>) {
794: chomp($line);
795: my ($timestamp,$host,$log)=split(/\:/,$line);
796: $log=&unescape($log);
797: my $include=1;
798: if (($filters{'start'}) && ($timestamp<$filters{'start'}))
799: { $include=0; }
800: if (($filters{'end'}) && ($timestamp>$filters{'end'}))
801: { $include=0; }
802: if (($filters{'action'} eq 'log') && ($log!~/^Log/)) { $include=0; }
803: if (($filters{'action'} eq 'check') && ($log!~/^Check/))
804: { $include=0; }
805: if ($include) {
806: push(@results,$timestamp.':'.$log);
807: }
808: }
809: close IN;
810: return join('&',sort(@results));
1.52 matthew 811: }
812:
813: ########################################################
814: ########################################################
815:
816: =pod
817:
818: =item Functions required for forking
819:
820: =over 4
821:
822: =item REAPER
823:
824: REAPER takes care of dead children.
825:
826: =item HUNTSMAN
827:
828: Signal handler for SIGINT.
829:
830: =item HUPSMAN
831:
832: Signal handler for SIGHUP
833:
834: =item DISCONNECT
835:
836: Disconnects from database.
837:
838: =back
839:
840: =cut
841:
842: ########################################################
843: ########################################################
844: sub REAPER { # takes care of dead children
845: $SIG{CHLD} = \&REAPER;
846: my $pid = wait;
847: $children --;
848: &logthis("Child $pid died");
849: delete $children{$pid};
850: }
851:
852: sub HUNTSMAN { # signal handler for SIGINT
853: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
854: kill 'INT' => keys %children;
855: my $execdir=$perlvar{'lonDaemons'};
856: unlink("$execdir/logs/lonsql.pid");
857: &logthis("<font color=red>CRITICAL: Shutting down</font>");
858: $unixsock = "mysqlsock";
859: my $port="$perlvar{'lonSockDir'}/$unixsock";
860: unlink($port);
861: exit; # clean up with dignity
862: }
863:
864: sub HUPSMAN { # signal handler for SIGHUP
865: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
866: kill 'INT' => keys %children;
867: close($server); # free up socket
868: &logthis("<font color=red>CRITICAL: Restarting</font>");
869: my $execdir=$perlvar{'lonDaemons'};
870: $unixsock = "mysqlsock";
871: my $port="$perlvar{'lonSockDir'}/$unixsock";
872: unlink($port);
873: exec("$execdir/lonsql"); # here we go again
874: }
875:
876: sub DISCONNECT {
877: $dbh->disconnect or
878: &logthis("<font color=blue>WARNING: Couldn't disconnect from database ".
879: " $DBI::errstr : $@</font>");
880: exit;
1.51 matthew 881: }
1.40 harris41 882:
883:
884:
885:
886:
887:
888:
889:
890:
891:
892:
1.51 matthew 893: # ----------------------------------- POD (plain old documentation, CPAN style)
1.40 harris41 894:
1.51 matthew 895: =pod
1.40 harris41 896:
1.51 matthew 897: =back
1.40 harris41 898:
899: =cut
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to lonsql CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom