loncom/lonsql - view

File: [LON-CAPA] / loncom / lonsql
Revision 1.55: download - view: text, annotated - select for diffs
Mon Feb 3 13:43:38 2003 UTC (21 years, 2 months ago) by albertel
Branches: MAIN
CVS tags: version_0_99_3, version_0_99_2, version_0_99_1, version_0_99_0, conference_2003, HEAD

- cleaning out unnessceary comments

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