rubbos/app/httpd-2.0.64/support/logresolve.pl.in

   1 #!@perlbin@
   2 #
   3 # Licensed to the Apache Software Foundation (ASF) under one or more
   4 # contributor license agreements.  See the NOTICE file distributed with
   5 # this work for additional information regarding copyright ownership.
   6 # The ASF licenses this file to You under the Apache License, Version 2.0
   7 # (the "License"); you may not use this file except in compliance with
   8 # the License.  You may obtain a copy of the License at
   9 #
  10 #     http://www.apache.org/licenses/LICENSE-2.0
  11 #
  12 # Unless required by applicable law or agreed to in writing, software
  13 # distributed under the License is distributed on an "AS IS" BASIS,
  14 # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  15 # See the License for the specific language governing permissions and
  16 # limitations under the License.
  17 #
  18 #
  19 # logresolve.pl
  20 #
  21 # v 1.2 by robh @ imdb.com
  22 #
  23 # usage: logresolve.pl <infile >outfile
  24 #
  25 # input = Apache/NCSA/.. logfile with IP numbers at start of lines
  26 # output = same logfile with IP addresses resolved to hostnames where
  27 #  name lookups succeeded.
  28 #
  29 # this differs from the C based 'logresolve' in that this script
  30 # spawns a number ($CHILDREN) of subprocesses to resolve addresses
  31 # concurrently and sets a short timeout ($TIMEOUT) for each lookup in
  32 # order to keep things moving quickly.
  33 #
  34 # the parent process handles caching of IP->hostnames using a Perl hash
  35 # it also avoids sending the same IP to multiple child processes to be
  36 # resolved multiple times concurrently.
  37 #
  38 # Depending on the settings of $CHILDREN and $TIMEOUT you should see
  39 # significant reductions in the overall time taken to resolve your
  40 # logfiles. With $CHILDREN=40 and $TIMEOUT=5 I've seen 200,000 - 300,000
  41 # logfile lines processed per hour compared to ~45,000 per hour
  42 # with 'logresolve'.
  43 #
  44 # I haven't yet seen any noticable reduction in the percentage of IPs
  45 # that fail to get resolved. Your mileage will no doubt vary. 5s is long
  46 # enough to wait IMO.
  47 #
  48 # Known to work with FreeBSD 2.2
  49 # Known to have problems with Solaris
  50 #
  51 # 980417 - use 'sockaddr_un' for bind/connect to make the script work
  52 #  with linux. Fix from Luuk de Boer <luuk_de_boer@pi.net>
  53
  54 require 5.004;
  55
  56 $|=1;
  57
  58 use FileHandle;
  59 use Socket;
  60
  61 use strict;
  62 no strict 'refs';
  63
  64 use vars qw($PROTOCOL);
  65 $PROTOCOL = 0;
  66
  67 my $CHILDREN = 40;
  68 my $TIMEOUT  = 5;
  69
  70 my $filename;
  71 my %hash = ();
  72 my $parent = $$;
  73
  74 my @children = ();
  75 for (my $child = 1; $child <=$CHILDREN; $child++) {
  76         my $f = fork();
  77         if (!$f) {
  78                 $filename = "./.socket.$parent.$child";
  79                 if (-e $filename) { unlink($filename) || warn "$filename .. $!\n";}
  80                 &child($child);
  81                 exit(0);
  82         }
  83         push(@children, $f);
  84 }
  85
  86 &parent;
  87 &cleanup;
  88
  89 ## remove all temporary files before shutting down
  90 sub cleanup {
  91          # die kiddies, die
  92         kill(15, @children);
  93         for (my $child = 1; $child <=$CHILDREN; $child++) {
  94                 if (-e "./.socket.$parent.$child") {
  95                         unlink("./.socket.$parent.$child")
  96                                 || warn ".socket.$parent.$child $!";
  97                 }
  98         }
  99 }
 100
 101 sub parent {
 102         # Trap some possible signals to trigger temp file cleanup
 103         $SIG{'KILL'} = $SIG{'INT'} = $SIG{'PIPE'} = \&cleanup;
 104
 105         my %CHILDSOCK;
 106         my $filename;
 107
 108          ## fork child processes. Each child will create a socket connection
 109          ## to this parent and use an unique temp filename to do so.
 110         for (my $child = 1; $child <=$CHILDREN; $child++) {
 111                 $CHILDSOCK{$child}= FileHandle->new;
 112
 113                 if (!socket($CHILDSOCK{$child}, AF_UNIX, SOCK_STREAM, $PROTOCOL)) {
 114                         warn "parent socket to child failed $!";
 115                 }
 116                 $filename = "./.socket.$parent.$child";
 117                 my $response;
 118                 do {
 119                         $response = connect($CHILDSOCK{$child}, sockaddr_un($filename));
 120                         if ($response != 1) {
 121                                 sleep(1);
 122                         }
 123                 } while ($response != 1);
 124                 $CHILDSOCK{$child}->autoflush;
 125         }
 126         ## All child processes should now be ready or at worst warming up
 127
 128         my (@buffer, $child, $ip, $rest, $hostname, $response);
 129          ## read the logfile lines from STDIN
 130         while(<STDIN>) {
 131                 @buffer = ();   # empty the logfile line buffer array.
 132                 $child = 1;             # children are numbered 1..N, start with #1
 133
 134                 # while we have a child to talk to and data to give it..
 135                 do {
 136                         push(@buffer, $_);                                      # buffer the line
 137                         ($ip, $rest) = split(/ /, $_, 2);       # separate IP form rest
 138
 139                         unless ($hash{$ip}) {                           # resolve if unseen IP
 140                                 $CHILDSOCK{$child}->print("$ip\n"); # pass IP to next child
 141                                 $hash{$ip} = $ip;                               # don't look it up again.
 142                                 $child++;
 143                         }
 144                 } while (($child < ($CHILDREN-1)) and ($_ = <STDIN>));
 145
 146                  ## now poll each child for a response
 147                 while (--$child > 0) {
 148                         $response = $CHILDSOCK{$child}->getline;
 149                         chomp($response);
 150                          # child sends us back both the IP and HOSTNAME, no need for us
 151                          # to remember what child received any given IP, and no worries
 152                          # what order we talk to the children
 153                         ($ip, $hostname) = split(/\|/, $response, 2);
 154                         $hash{$ip} = $hostname;
 155                 }
 156
 157                  # resolve all the logfiles lines held in the log buffer array..
 158                 for (my $line = 0; $line <=$#buffer; $line++) {
 159                          # get next buffered line
 160                         ($ip, $rest) = split(/ /, $buffer[$line], 2);
 161                          # separate IP from rest and replace with cached hostname
 162                         printf STDOUT ("%s %s", $hash{$ip}, $rest);
 163                 }
 164         }
 165 }
 166
 167 ########################################
 168
 169 sub child {
 170          # arg = numeric ID - how the parent refers to me
 171         my $me = shift;
 172
 173          # add trap for alarm signals.
 174         $SIG{'ALRM'} = sub { die "alarmed"; };
 175
 176          # create a socket to communicate with parent
 177         socket(INBOUND, AF_UNIX, SOCK_STREAM, $PROTOCOL)
 178                 || die "Error with Socket: !$\n";
 179         $filename = "./.socket.$parent.$me";
 180         bind(INBOUND, sockaddr_un($filename))
 181                 || die "Error Binding $filename: $!\n";
 182         listen(INBOUND, 5) || die "Error Listening: $!\n";
 183
 184         my ($ip, $send_back);
 185         my $talk = FileHandle->new;
 186
 187          # accept a connection from the parent process. We only ever have
 188          # have one connection where we exchange 1 line of info with the
 189          # parent.. 1 line in (IP address), 1 line out (IP + hostname).
 190         accept($talk, INBOUND) || die "Error Accepting: $!\n";
 191          # disable I/O buffering just in case
 192         $talk->autoflush;
 193          # while the parent keeps sending data, we keep responding..
 194         while(($ip = $talk->getline)) {
 195                 chomp($ip);
 196                  # resolve the IP if time permits and send back what we found..
 197                 $send_back = sprintf("%s|%s", $ip, &nslookup($ip));
 198                 $talk->print($send_back."\n");
 199         }
 200 }
 201
 202 # perform a time restricted hostname lookup.
 203 sub nslookup {
 204          # get the IP as an arg
 205         my $ip = shift;
 206         my $hostname = undef;
 207
 208          # do the hostname lookup inside an eval. The eval will use the
 209          # already configured SIGnal handler and drop out of the {} block
 210          # regardless of whether the alarm occured or not.
 211         eval {
 212                 alarm($TIMEOUT);
 213                 $hostname = gethostbyaddr(gethostbyname($ip), AF_INET);
 214                 alarm(0);
 215         };
 216         if ($@ =~ /alarm/) {
 217                  # useful for debugging perhaps..
 218                 # print "alarming, isn't it? ($ip)";
 219         }
 220
 221          # return the hostname or the IP address itself if there is no hostname
 222         $hostname ne "" ? $hostname : $ip;
 223 }
 224
 225