src/perlmods/OpenSRF/Utils/LogServer.pm

   1 package OpenSRF::Utils::LogServer;
   2 use strict; use warnings;
   3 use base qw(OpenSRF);
   4 use IO::Socket::INET;
   5 use FileHandle;
   6 use OpenSRF::Utils::Config;
   7 use Fcntl;
   8 use Time::HiRes qw(gettimeofday);
   9 use OpenSRF::Utils::Logger;
  10
  11 =head2 Name
  12
  13 OpenSRF::Utils::LogServer
  14
  15 =cut
  16
  17 =head2 Synopsis
  18
  19 Networ Logger
  20
  21 =cut
  22
  23 =head2 Description
  24
  25
  26 =cut
  27
  28
  29
  30 our $config;
  31 our $port;
  32 our $bufsize = 4096;
  33 our $proto;
  34 our @file_info;
  35
  36
  37 sub DESTROY {
  38         for my $file (@file_info) {
  39                 if( $file->handle ) {
  40                         close( $file->handle );
  41                 }
  42         }
  43 }
  44
  45
  46 sub serve {
  47
  48         $config = OpenSRF::Utils::Config->current;
  49
  50         unless ($config) { throw OpenSRF::EX::Config ("No suitable config found"); }
  51
  52         $port = $config->system->log_port;
  53         $proto = $config->system->log_proto;
  54
  55
  56         my $server = IO::Socket::INET->new(
  57                 LocalPort       => $port,
  58                 Proto                   => $proto )
  59         or die "Error creating server socket : $@\n";
  60
  61
  62
  63         while ( 1 ) {
  64                 my $client = <$server>;
  65                 process( $client );
  66         }
  67
  68         close( $server );
  69 }
  70
  71 sub process {
  72         my $client = shift;
  73         my @params = split(/\|/,$client);
  74         my $log = shift @params;
  75
  76         if( (!$log) || (!@params) ) {
  77                 warn "Invalid logging params: $log\n";
  78                 return;
  79         }
  80
  81         # Put |'s back in since they are stripped
  82         # from the message by 'split'
  83         my $message;
  84         if( @params > 1 ) {
  85                 foreach my $param (@params) {
  86                         if( $param ne $params[0] ) {
  87                                 $message .= "|";
  88                         }
  89                         $message .= $param;
  90                 }
  91         }
  92         else{ $message = "@params"; }
  93
  94         my @lines = split( "\n", $message );
  95         my $time = format_time();
  96
  97         my $fh;
  98
  99         my ($f_obj) = grep { $_->name eq $log } @file_info;
 100
 101         unless( $f_obj and ($fh=$f_obj->handle) ) {
 102                 my $file = $config->logs->$log;
 103
 104                 sysopen( $fh, $file, O_WRONLY|O_APPEND|O_CREAT )
 105                         or warn "Cannot sysopen $log: $!";
 106                 $fh->autoflush(1);
 107
 108                 my $obj = new OpenSRF::Utils::NetLogFile( $log, $file, $fh );
 109                 push @file_info, $obj;
 110         }
 111
 112         foreach my $line (@lines) {
 113                 print $fh "$time $line\n" || die "$!";
 114         }
 115
 116 }
 117
 118 sub format_time {
 119         my ($s, $ms) = gettimeofday();
 120         my @time = localtime( $s );
 121         $ms = substr( $ms, 0, 3 );
 122         my $year = $time[5] + 1900;
 123         my $mon = $time[4] + 1;
 124         my $day = $time[3];
 125         my $hour = $time[2];
 126         my $min = $time[1];
 127         my $sec = $time[0];
 128         $mon = "0" . "$mon" if ( length($mon) == 1 );
 129         $day = "0" . "$day" if ( length($day) == 1 );
 130         $hour = "0" . "$hour" if ( length($hour) == 1 );
 131         $min = "0" . "$min" if (length($min) == 1 );
 132         $sec = "0" . "$sec" if (length($sec) == 1 );
 133
 134         my $proc = $$;
 135         while( length( $proc ) < 5 ) { $proc = "0" . "$proc"; }
 136         return "[$year-$mon-$day $hour:$min:$sec.$ms $proc]";
 137 }
 138
 139
 140 package OpenSRF::Utils::NetLogFile;
 141
 142 sub new{ return bless( [ $_[1], $_[2], $_[3] ], $_[0] ); }
 143
 144 sub name { return $_[0]->[0]; }
 145 sub file { return $_[0]->[1]; }
 146 sub handle { return $_[0]->[2]; }
 147
 148
 149 1;