loncom/lonsql - view

File: [LON-CAPA] / loncom / lonsql
Revision 1.52: download - view: text, annotated - select for diffs
Tue Aug 13 19:40:57 2002 UTC (21 years, 8 months ago) by matthew
Branches: MAIN
CVS tags: HEAD

This appears to work, but frankly I wouldn't trust it.  Fixed enough of the
errors that it runs, forks, and returns search results.  Theoretically, it
should also do the logfile searches, too.

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