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