1: #!/usr/bin/perl
2: # lonsql-based on the preforker:harsha jagasia:date:5/10/00
3: # 7/25 Gerd Kortemeyer
4: # many different dates Scott Harrison
5:
6: use IO::Socket;
7: use Symbol;
8: use POSIX;
9: use IO::Select;
10: use IO::File;
11: use Socket;
12: use Fcntl;
13: use Tie::RefHash;
14: use DBI;
15:
16:
17: $childmaxattempts=10;
18: $run =0;#running counter to generate the query-id
19:
20: # ------------------------------------ Read httpd access.conf and get variables
21: open (CONFIG,"/etc/httpd/conf/access.conf") || die "Can't read access.conf";
22:
23: while ($configline=<CONFIG>) {
24: if ($configline =~ /PerlSetVar/) {
25: my ($dummy,$varname,$varvalue)=split(/\s+/,$configline);
26: chomp($varvalue);
27: $perlvar{$varname}=$varvalue;
28: }
29: }
30: close(CONFIG);
31:
32: # --------------------------------------------- Check if other instance running
33:
34: my $pidfile="$perlvar{'lonDaemons'}/logs/lonsql.pid";
35:
36: if (-e $pidfile) {
37: my $lfh=IO::File->new("$pidfile");
38: my $pide=<$lfh>;
39: chomp($pide);
40: if (kill 0 => $pide) { die "already running"; }
41: }
42:
43: # ------------------------------------------------------------- Read hosts file
44: $PREFORK=4; # number of children to maintain, at least four spare
45:
46: open (CONFIG,"$perlvar{'lonTabDir'}/hosts.tab") || die "Can't read host file";
47:
48: while ($configline=<CONFIG>) {
49: my ($id,$domain,$role,$name,$ip)=split(/:/,$configline);
50: chomp($ip);
51:
52: $hostip{$ip}=$id;
53:
54: if ($id eq $perlvar{'lonHostID'}) { $thisserver=$name; }
55:
56: $PREFORK++;
57: }
58: close(CONFIG);
59:
60: $unixsock = "mysqlsock";
61: my $localfile="$perlvar{'lonSockDir'}/$unixsock";
62: my $server;
63: unlink ($localfile);
64: unless ($server=IO::Socket::UNIX->new(Local =>"$localfile",
65: Type => SOCK_STREAM,
66: Listen => 10))
67: {
68: print "in socket error:$@\n";
69: }
70:
71: # -------------------------------------------------------- Routines for forking
72: # global variables
73: $MAX_CLIENTS_PER_CHILD = 5; # number of clients each child should process
74: %children = (); # keys are current child process IDs
75: $children = 0; # current number of children
76:
77: sub REAPER { # takes care of dead children
78: $SIG{CHLD} = \&REAPER;
79: my $pid = wait;
80: $children --;
81: &logthis("Child $pid died");
82: delete $children{$pid};
83: }
84:
85: sub HUNTSMAN { # signal handler for SIGINT
86: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
87: kill 'INT' => keys %children;
88: my $execdir=$perlvar{'lonDaemons'};
89: unlink("$execdir/logs/lonsql.pid");
90: &logthis("<font color=red>CRITICAL: Shutting down</font>");
91: $unixsock = "mysqlsock";
92: my $port="$perlvar{'lonSockDir'}/$unixsock";
93: unlink(port);
94: exit; # clean up with dignity
95: }
96:
97: sub HUPSMAN { # signal handler for SIGHUP
98: local($SIG{CHLD}) = 'IGNORE'; # we're going to kill our children
99: kill 'INT' => keys %children;
100: close($server); # free up socket
101: &logthis("<font color=red>CRITICAL: Restarting</font>");
102: my $execdir=$perlvar{'lonDaemons'};
103: $unixsock = "mysqlsock";
104: my $port="$perlvar{'lonSockDir'}/$unixsock";
105: unlink(port);
106: exec("$execdir/lonsql"); # here we go again
107: }
108:
109: sub logthis {
110: my $message=shift;
111: my $execdir=$perlvar{'lonDaemons'};
112: my $fh=IO::File->new(">>$execdir/logs/lonsqlfinal.log");
113: my $now=time;
114: my $local=localtime($now);
115: print $fh "$local ($$): $message\n";
116: }
117: # ---------------------------------------------------- Fork once and dissociate
118: $fpid=fork;
119: exit if $fpid;
120: die "Couldn't fork: $!" unless defined ($fpid);
121:
122: POSIX::setsid() or die "Can't start new session: $!";
123:
124: # ------------------------------------------------------- Write our PID on disk
125:
126: $execdir=$perlvar{'lonDaemons'};
127: open (PIDSAVE,">$execdir/logs/lonsql.pid");
128: print PIDSAVE "$$\n";
129: close(PIDSAVE);
130: &logthis("<font color=red>CRITICAL: ---------- Starting ----------</font>");
131:
132: # ----------------------------- Ignore signals generated during initial startup
133: $SIG{HUP}=$SIG{USR1}='IGNORE';
134: # ------------------------------------------------------- Now we are on our own
135: # Fork off our children.
136: for (1 .. $PREFORK) {
137: make_new_child();
138: }
139:
140: # Install signal handlers.
141: $SIG{CHLD} = \&REAPER;
142: $SIG{INT} = $SIG{TERM} = \&HUNTSMAN;
143: $SIG{HUP} = \&HUPSMAN;
144:
145: # And maintain the population.
146: while (1) {
147: sleep; # wait for a signal (i.e., child's death)
148: for ($i = $children; $i < $PREFORK; $i++) {
149: make_new_child(); # top up the child pool
150: }
151: }
152:
153:
154: sub make_new_child {
155: my $pid;
156: my $sigset;
157:
158: # block signal for fork
159: $sigset = POSIX::SigSet->new(SIGINT);
160: sigprocmask(SIG_BLOCK, $sigset)
161: or die "Can't block SIGINT for fork: $!\n";
162:
163: die "fork: $!" unless defined ($pid = fork);
164:
165: if ($pid) {
166: # Parent records the child's birth and returns.
167: sigprocmask(SIG_UNBLOCK, $sigset)
168: or die "Can't unblock SIGINT for fork: $!\n";
169: $children{$pid} = 1;
170: $children++;
171: return;
172: } else {
173: # Child can *not* return from this subroutine.
174: $SIG{INT} = 'DEFAULT'; # make SIGINT kill us as it did before
175:
176: # unblock signals
177: sigprocmask(SIG_UNBLOCK, $sigset)
178: or die "Can't unblock SIGINT for fork: $!\n";
179:
180:
181: #open database handle
182: # making dbh global to avoid garbage collector
183: unless (
184: $dbh = DBI->connect("DBI:mysql:loncapa","www","123",{ RaiseError =>0,PrintError=>0})
185: ) {
186: my $st=120+int(rand(240));
187: &logthis("<font color=blue>WARNING: Couldn't connect to database ($st secs): $@</font>");
188: print "database handle error\n";
189: sleep($st);
190: exit;
191:
192: };
193: # make sure that a database disconnection occurs with ending kill signals
194: $SIG{TERM}=$SIG{INT}=$SIG{QUIT}=$SIG{__DIE__}=\&DISCONNECT;
195:
196: # handle connections until we've reached $MAX_CLIENTS_PER_CHILD
197: for ($i=0; $i < $MAX_CLIENTS_PER_CHILD; $i++) {
198: $client = $server->accept() or last;
199:
200: # do something with the connection
201: $run = $run+1;
202: my $userinput = <$client>;
203: chomp($userinput);
204:
205: my ($conserver,$querytmp)=split(/&/,$userinput);
206: my $query=unescape($querytmp);
207:
208: #send query id which is pid_unixdatetime_runningcounter
209: $queryid = $thisserver;
210: $queryid .="_".($$)."_";
211: $queryid .= time."_";
212: $queryid .= $run;
213: print $client "$queryid\n";
214:
215: #prepare and execute the query
216: my $sth = $dbh->prepare($query);
217: my $result;
218: unless ($sth->execute())
219: {
220: &logthis("<font color=blue>WARNING: Could not retrieve from database: $@</font>");
221: $result="";
222: }
223: else {
224: my $r1=$sth->fetchall_arrayref;
225: my @r2; map {my $a=$_; my @b=map {escape($_)} @$a; push @r2,join(",", @b)} (@$r1);
226: $result=join("&",@r2) . "\n";
227: }
228: &reply("queryreply:$queryid:$result",$conserver);
229:
230: }
231:
232: # tidy up gracefully and finish
233:
234: #close the database handle
235: $dbh->disconnect
236: or &logthis("<font color=blue>WARNING: Couldn't disconnect from database $DBI::errstr ($st secs): $@</font>");
237:
238: # this exit is VERY important, otherwise the child will become
239: # a producer of more and more children, forking yourself into
240: # process death.
241: exit;
242: }
243: }
244:
245: sub DISCONNECT {
246: $dbh->disconnect or
247: &logthis("<font color=blue>WARNING: Couldn't disconnect from database $DBI::errstr ($st secs): $@</font>");
248: exit;
249: }
250:
251: # -------------------------------------------------- Non-critical communication
252:
253: sub subreply {
254: my ($cmd,$server)=@_;
255: my $peerfile="$perlvar{'lonSockDir'}/$server";
256: my $sclient=IO::Socket::UNIX->new(Peer =>"$peerfile",
257: Type => SOCK_STREAM,
258: Timeout => 10)
259: or return "con_lost";
260: print $sclient "$cmd\n";
261: my $answer=<$sclient>;
262: chomp($answer);
263: if (!$answer) { $answer="con_lost"; }
264: return $answer;
265: }
266:
267: sub reply {
268: my ($cmd,$server)=@_;
269: my $answer;
270: if ($server ne $perlvar{'lonHostID'}) {
271: $answer=subreply($cmd,$server);
272: if ($answer eq 'con_lost') {
273: $answer=subreply("ping",$server);
274: $answer=subreply($cmd,$server);
275: }
276: } else {
277: $answer='self_reply';
278: }
279: return $answer;
280: }
281:
282: # -------------------------------------------------------- Escape Special Chars
283:
284: sub escape {
285: my $str=shift;
286: $str =~ s/(\W)/"%".unpack('H2',$1)/eg;
287: return $str;
288: }
289:
290: # ----------------------------------------------------- Un-Escape Special Chars
291:
292: sub unescape {
293: my $str=shift;
294: $str =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C",hex($1))/eg;
295: return $str;
296: }
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