loncom/lonsql - view

File: [LON-CAPA] / loncom / lonsql
Revision 1.51: download - view: text, annotated - select for diffs
Tue Aug 6 13:48:47 2002 UTC (21 years, 9 months ago) by matthew
Branches: MAIN
CVS tags: HEAD

Many, many changes.
THIS CODE SHOULD NOT BE USED AT THIS TIME.  It does not run.

Added POD comments everywhere.
Now use File::Find instead of requiring find.pl, which I could never find.
Now use strict.
Rearranged most of the code.
Added &do_sql_query.
&userlog and &courselog were not modified but were moved.

1: #!/usr/bin/perl 2: 3: # The LearningOnline Network 4: # lonsql - LON TCP-MySQL-Server Daemon for handling database requests. 5: # 6: # $Id: lonsql,v 1.51 2002/08/06 13:48:47 matthew Exp $ 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: # 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; 54: 55: use lib '/home/httpd/lib/perl/'; 56: use LONCAPA::Configuration; 57: 58: use IO::Socket; 59: use Symbol; 60: use POSIX; 61: use IO::Select; 62: use IO::File; 63: use Socket; 64: use Fcntl; 65: use Tie::RefHash; 66: use DBI; 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 94: 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 112: 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 Functions required for forking 125: 126: =over 4 127: 128: =item REAPER 129: 130: REAPER takes care of dead children. 131: 132: =item HUNTSMAN 133: 134: Signal handler for SIGINT. 135: 136: =item HUPSMAN 137: 138: Signal handler for SIGHUP 139: 140: =item DISCONNECT 141: 142: Disconnects from database. 143: 144: =back 145: 146: =cut 147: 148: ######################################################## 149: ######################################################## 150: sub REAPER { # takes care of dead children 151: $SIG{CHLD} = \&REAPER; 152: my $pid = wait; 153: $children --; 154: &logthis("Child $pid died"); 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("CRITICAL: Shutting down"); 164: $unixsock = "mysqlsock"; 165: my $port="$perlvar{'lonSockDir'}/$unixsock"; 166: unlink($port); 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("CRITICAL: Restarting"); 175: my $execdir=$perlvar{'lonDaemons'}; 176: $unixsock = "mysqlsock"; 177: my $port="$perlvar{'lonSockDir'}/$unixsock"; 178: unlink($port); 179: exec("$execdir/lonsql"); # here we go again 180: } 181: 182: sub DISCONNECT { 183: $dbh->disconnect or 184: &logthis("WARNING: Couldn't disconnect from database ". 185: " $DBI::errstr : $@"); 186: exit; 187: } 188: 189: ################################################################### 190: ################################################################### 191: 192: =pod 193: 194: =item Main body of code. 195: 196: =over 4 197: 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: } 254: # 255: # Read hosts file 256: # 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++; 267: } 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"; 282: } 283: ######################################################## 284: ######################################################## 285: # 286: # Fork once and dissociate 287: my $fpid=fork; 288: exit if $fpid; 289: die "Couldn't fork: $!" unless defined ($fpid); 290: POSIX::setsid() or die "Can't start new session: $!"; 291: # 292: # Write our PID on disk 293: my $execdir=$perlvar{'lonDaemons'}; 294: open (PIDSAVE,">$execdir/logs/lonsql.pid"); 295: print PIDSAVE "$$\n"; 296: close(PIDSAVE); 297: &logthis("CRITICAL: ---------- Starting ----------"); 298: # 299: # Ignore signals generated during initial startup 300: $SIG{HUP}=$SIG{USR1}='IGNORE'; 301: # Now we are on our own 302: # Fork off our children. 303: for (1 .. $PREFORK) { 304: make_new_child(); 305: } 306: # 307: # Install signal handlers. 308: $SIG{CHLD} = \&REAPER; 309: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN; 310: $SIG{HUP} = \&HUPSMAN; 311: # 312: # And maintain the population. 313: while (1) { 314: sleep; # wait for a signal (i.e., child's death) 315: for (my $i = $children; $i < $PREFORK; $i++) { 316: make_new_child(); # top up the child pool 317: } 318: } 319: 320: ######################################################## 321: ######################################################## 322: 323: =pod 324: 325: =item &make_new_child 326: 327: Inputs: None 328: 329: Returns: None 330: 331: =cut 332: 333: ######################################################## 334: ######################################################## 335: sub make_new_child { 336: my $pid; 337: my $sigset; 338: # 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"; 343: # 344: die "fork: $!" unless defined ($pid = fork); 345: # 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 { 354: # Child can *not* return from this subroutine. 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"; 359: #open database handle 360: # making dbh global to avoid garbage collector 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("WARNING: Couldn't connect to database". 366: ": $@"); 367: # "($st secs): $@"); 368: print "database handle error\n"; 369: exit; 370: } 371: # make sure that a database disconnection occurs with 372: # ending kill signals 373: $SIG{TERM}=$SIG{INT}=$SIG{QUIT}=$SIG{__DIE__}=\&DISCONNECT; 374: # handle connections until we've reached $MAX_CLIENTS_PER_CHILD 375: for (my $i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) { 376: my $client = $server->accept() or last; 377: # do something with the connection 378: $run = $run+1; 379: my $userinput = <$client>; 380: chomp($userinput); 381: # 382: my ($conserver,$query, 383: $arg1,$arg2,$arg3)=split(/&/,$userinput); 384: my $query=unescape($query); 385: # 386: #send query id which is pid_unixdatetime_runningcounter 387: my $queryid = $thisserver; 388: $queryid .="_".($$)."_"; 389: $queryid .= time."_"; 390: $queryid .= $run; 391: print $client "$queryid\n"; 392: # 393: &logthis("QUERY: $query - $arg1 - $arg2 - $arg3"); 394: sleep 1; 395: # 396: my $result=''; 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: } 422: # result does not need to be escaped because it has already been 423: # escaped. 424: #$result=&escape($result); 425: # reply with result, append \n unless already there 426: $result.="\n" unless ($result=~/\n$/); 427: &reply("queryreply:$queryid:$result",$conserver); 428: } 429: # tidy up gracefully and finish 430: # 431: # close the database handle 432: $dbh->disconnect 433: or &logthis("WARNING: Couldn't disconnect". 434: " from database $DBI::errstr : $@"); 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: } 440: } 441: 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("WARNING: ". 489: "Could not retrieve from database: $@"); 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"; 593: } 594: 595: # -------------------------------------------------- Non-critical communication 596: 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: ######################################################## 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); 624: $answer="con_lost" if (!$answer); 625: return $answer; 626: } 627: 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: ######################################################## 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'; 656: $answer=subreply($cmd,$server); 657: } 658: return $answer; 659: } 660: 661: ######################################################## 662: ######################################################## 663: 664: =pod 665: 666: =item &escape 667: 668: Escape special characters in a string. 669: 670: Inputs: string to escape 671: 672: Returns: The input string with special characters escaped. 673: 674: =cut 675: 676: ######################################################## 677: ######################################################## 678: sub escape { 679: my $str=shift; 680: $str =~ s/(\W)/"%".unpack('H2',$1)/eg; 681: return $str; 682: } 683: 684: ######################################################## 685: ######################################################## 686: 687: =pod 688: 689: =item &unescape 690: 691: Unescape special characters in a string. 692: 693: Inputs: string to unescape 694: 695: Returns: The input string with special characters unescaped. 696: 697: =cut 698: 699: ######################################################## 700: ######################################################## 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: } 706: 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: ######################################################## 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: 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: ######################################################## 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: } 761: 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. 843: 844: =cut 845: 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: } 876: 877: 878: 879: 880: 881: 882: 883: 884: 885: 886: 887: # ----------------------------------- POD (plain old documentation, CPAN style) 888: 889: =pod 890: 891: =back 892: 893: =cut