← Back to branch summary

~percona-core/percona-toolkit/release-2.2.8-v2

« back to all changes in this revision

Viewing changes to lib/Percona/Agent/Logger.pm

  • Committer: Daniel Nichter
  • Date: 2014-05-30 01:09:13 UTC
  • mfrom: (598.5.6 release-2.2.8)
  • Revision ID: daniel@percona.com-20140530010913-4wep0en37aa4vvok
Merge release-2.2.8.

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/Percona/Agent/Logger.pm
1
 
# This program is copyright 2013 Percona Ireland Ltd.
2
 
# Feedback and improvements are welcome.
3
 
#
4
 
# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
5
 
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
6
 
# MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.
7
 
#
8
 
# This program is free software; you can redistribute it and/or modify it under
9
 
# the terms of the GNU General Public License as published by the Free Software
10
 
# Foundation, version 2; OR the Perl Artistic License.  On UNIX and similar
11
 
# systems, you can issue `man perlgpl' or `man perlartistic' to read these
12
 
# licenses.
13
 
#
14
 
# You should have received a copy of the GNU General Public License along with
15
 
# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
16
 
# Place, Suite 330, Boston, MA  02111-1307  USA.
17
 
# ###########################################################################
18
 
# Percona::Agent::Logger package
19
 
# ###########################################################################
20
 
package Percona::Agent::Logger;
21
 
 
22
 
use strict;
23
 
use warnings FATAL => 'all';
24
 
use English qw(-no_match_vars);
25
 
 
26
 
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
27
 
 
28
 
use POSIX qw(SIGALRM);
29
 
 
30
 
use Lmo;
31
 
use Transformers;
32
 
use Percona::WebAPI::Resource::LogEntry;
33
 
 
34
 
Transformers->import(qw(ts));
35
 
 
36
 
has 'exit_status' => (
37
 
   is       => 'rw',
38
 
   isa      => 'ScalarRef',
39
 
   required => 1,
40
 
);
41
 
 
42
 
has 'pid' => (
43
 
   is       => 'ro',
44
 
   isa      => 'Int',
45
 
   required => 1,
46
 
);
47
 
 
48
 
has 'service' => (
49
 
   is       => 'rw',
50
 
   isa      => 'Maybe[Str]',
51
 
   required => 0,
52
 
   default  => sub { return; },
53
 
);
54
 
 
55
 
has 'data_ts' => (
56
 
   is       => 'rw',
57
 
   isa      => 'Maybe[Int]',
58
 
   required => 0,
59
 
   default  => sub { return; },
60
 
);
61
 
 
62
 
has 'online_logging' => (
63
 
   is       => 'ro',
64
 
   isa      => 'Bool',
65
 
   required => 0,
66
 
   default  => sub { return 1 },
67
 
);
68
 
 
69
 
has 'online_logging_enabled' => (
70
 
   is       => 'rw',
71
 
   isa      => 'Bool',
72
 
   required => 0,
73
 
   default  => sub { return 0 },
74
 
);
75
 
 
76
 
has 'quiet' => (
77
 
   is       => 'rw',
78
 
   isa      => 'Int',
79
 
   required => 0,
80
 
   default  => sub { return 0 },
81
 
);
82
 
 
83
 
has '_buffer' => (
84
 
   is       => 'rw',
85
 
   isa      => 'ArrayRef',
86
 
   required => 0,
87
 
   default  => sub { return []; },
88
 
);
89
 
 
90
 
has '_pipe_write' => (
91
 
   is       => 'rw',
92
 
   isa      => 'Maybe[FileHandle]',
93
 
   required => 0,
94
 
);
95
 
 
96
 
sub read_stdin {
97
 
   my ( $t ) = @_;
98
 
 
99
 
   # Set the SIGALRM handler.
100
 
   POSIX::sigaction(
101
 
      SIGALRM,
102
 
      POSIX::SigAction->new(sub { die 'read timeout'; }),
103
 
   ) or die "Error setting SIGALRM handler: $OS_ERROR";
104
 
 
105
 
   my $timeout = 0;
106
 
   my @lines;
107
 
   eval {
108
 
      alarm $t;
109
 
      while(defined(my $line = <STDIN>)) {
110
 
         push @lines, $line;
111
 
      }
112
 
      alarm 0;
113
 
   };
114
 
   if ( $EVAL_ERROR ) {
115
 
      PTDEBUG && _d('Read error:', $EVAL_ERROR);
116
 
      die $EVAL_ERROR unless $EVAL_ERROR =~ m/read timeout/;
117
 
      $timeout = 1;
118
 
   }
119
 
   return unless scalar @lines || $timeout;
120
 
   return \@lines;
121
 
}
122
 
 
123
 
sub start_online_logging {
124
 
   my ($self, %args) = @_;
125
 
   my $client       = $args{client};
126
 
   my $log_link     = $args{log_link};
127
 
   my $read_timeout = $args{read_timeout} || 3;
128
 
 
129
 
   return unless $self->online_logging;
130
 
 
131
 
   my $pid = open(my $pipe_write, "|-");
132
 
 
133
 
   if ($pid) {
134
 
      # parent
135
 
      select $pipe_write;
136
 
      $OUTPUT_AUTOFLUSH = 1;
137
 
      $self->_pipe_write($pipe_write);
138
 
      $self->online_logging_enabled(1);
139
 
   }
140
 
   else {
141
 
      # child
142
 
      my @log_entries;
143
 
      my $n_errors = 0;
144
 
      my $oktorun  = 1;
145
 
      QUEUE:
146
 
      while ($oktorun) {
147
 
         my $lines = read_stdin($read_timeout);
148
 
         last QUEUE unless $lines;
149
 
         LINE:
150
 
         while ( defined(my $line = shift @$lines) ) {
151
 
            # $line = ts,level,n_lines,message
152
 
            my ($ts, $level, $n_lines, $msg) = $line =~ m/^([^,]+),([^,]+),([^,]+),(.+)/s;
153
 
            if ( !$ts || !$level || !$n_lines || !$msg ) {
154
 
               warn "$line\n";
155
 
               next LINE;
156
 
            }
157
 
            if ( $n_lines > 1 ) {
158
 
               $n_lines--;  # first line
159
 
               for ( 1..$n_lines ) {
160
 
                  $msg .= shift @$lines;
161
 
               }
162
 
            }
163
 
 
164
 
            push @log_entries, Percona::WebAPI::Resource::LogEntry->new(
165
 
               pid       => $self->pid,
166
 
               entry_ts  => $ts,
167
 
               log_level => $level,
168
 
               message   => $msg,
169
 
               ($self->service ? (service => $self->service) : ()),
170
 
               ($self->data_ts ? (data_ts => $self->data_ts) : ()),
171
 
            );
172
 
         }  # LINE
173
 
 
174
 
         if ( scalar @log_entries ) { 
175
 
            eval {
176
 
               $client->post(
177
 
                  link      => $log_link,
178
 
                  resources => \@log_entries,
179
 
               );
180
 
            };
181
 
            if ( my $e = $EVAL_ERROR ) {
182
 
               # Safegaurd: don't spam the agent log file with errors.
183
 
               if ( ++$n_errors <= 10 ) {
184
 
                  warn "Error sending log entry to API: $e";
185
 
                  if ( $n_errors == 10 ) {
186
 
                     my $ts = ts(time, 1);  # 1=UTC
187
 
                     warn "$ts WARNING $n_errors consecutive errors, no more "
188
 
                        . "error messages will be printed until log entries "
189
 
                        . "are sent successfully again.\n";
190
 
                  }
191
 
               }
192
 
            }
193
 
            else {
194
 
               @log_entries = ();
195
 
               $n_errors    = 0;
196
 
            }
197
 
         }  # have log entries
198
 
 
199
 
         # Safeguard: don't use too much memory if we lose connection
200
 
         # to the API for a long time.
201
 
         my $n_log_entries = scalar @log_entries;
202
 
         if ( $n_log_entries > 1_000 ) {
203
 
            warn "$n_log_entries log entries in send buffer, "
204
 
               . "removing first 100 to avoid excessive usage.\n";
205
 
            @log_entries = @log_entries[100..($n_log_entries-1)];
206
 
         }
207
 
      }  # QUEUE
208
 
 
209
 
      if ( scalar @log_entries ) {
210
 
         my $ts = ts(time, 1);  # 1=UTC
211
 
         warn "$ts WARNING Failed to send these log entries "
212
 
            . "(timestamps are UTC):\n";
213
 
         foreach my $log ( @log_entries ) {
214
 
            warn sprintf("%s %s %s\n",
215
 
               $log->entry_ts,
216
 
               level_name($log->log_level),
217
 
               $log->message,
218
 
            );
219
 
         }
220
 
      }
221
 
 
222
 
      exit 0;
223
 
   } # child
224
 
 
225
 
   return;
226
 
}
227
 
 
228
 
sub level_number {
229
 
   my $name = shift;
230
 
   die "No log level name given" unless $name;
231
 
   my $number = $name eq 'DEBUG'   ? 1
232
 
              : $name eq 'INFO'    ? 2
233
 
              : $name eq 'WARNING' ? 3
234
 
              : $name eq 'ERROR'   ? 4
235
 
              : $name eq 'FATAL'   ? 5
236
 
              : die "Invalid log level name: $name";
237
 
}
238
 
 
239
 
sub level_name {
240
 
   my $number = shift;
241
 
   die "No log level name given" unless $number;
242
 
   my $name = $number == 1 ? 'DEBUG'
243
 
            : $number == 2 ? 'INFO'
244
 
            : $number == 3 ? 'WARNING'
245
 
            : $number == 4 ? 'ERROR'
246
 
            : $number == 5 ? 'FATAL'
247
 
            : die "Invalid log level number: $number";
248
 
}
249
 
 
250
 
sub debug {
251
 
   my $self = shift;
252
 
   return if $self->online_logging;
253
 
   return $self->_log(0, 'DEBUG', @_);
254
 
}
255
 
 
256
 
sub info {
257
 
   my $self = shift;
258
 
   return $self->_log(1, 'INFO', @_);
259
 
}
260
 
 
261
 
sub warning {
262
 
   my $self = shift;
263
 
   $self->_set_exit_status();
264
 
   return $self->_log(1, 'WARNING', @_);
265
 
}
266
 
 
267
 
sub error {
268
 
   my $self = shift;
269
 
   $self->_set_exit_status();
270
 
   return $self->_log(1, 'ERROR', @_);
271
 
}
272
 
 
273
 
sub fatal {
274
 
   my $self = shift;
275
 
   $self->_set_exit_status();
276
 
   $self->_log(1, 'FATAL', @_);
277
 
   exit $self->exit_status;
278
 
}
279
 
 
280
 
sub _set_exit_status {
281
 
   my $self = shift;
282
 
   # exit_status is a scalar ref
283
 
   my $exit_status = $self->exit_status;  # get ref
284
 
   $$exit_status |= 1;                    # deref to set
285
 
   $self->exit_status($exit_status);      # save back ref
286
 
   return;
287
 
}
288
 
 
289
 
sub _log {
290
 
   my ($self, $online, $level, $msg) = @_;
291
 
 
292
 
   my $ts = ts(time, 1);  # 1=UTC
293
 
   my $level_number = level_number($level);
294
 
 
295
 
   return if $self->quiet && $level_number < $self->quiet;
296
 
 
297
 
   chomp($msg);
298
 
   my $n_lines = 1;
299
 
   $n_lines++ while $msg =~ m/\n/g;
300
 
 
301
 
   if ( $online && $self->online_logging_enabled ) {
302
 
      while ( defined(my $log_entry = shift @{$self->_buffer}) ) {
303
 
         $self->_queue_log_entry(@$log_entry);
304
 
      }
305
 
      $self->_queue_log_entry($ts, $level_number, $n_lines, $msg);
306
 
   }
307
 
   else {
308
 
      if ( $online && $self->online_logging ) {
309
 
         push @{$self->_buffer}, [$ts, $level_number, $n_lines, $msg];
310
 
      }
311
 
 
312
 
      if ( $level_number >= 3 ) {  # warning
313
 
         print STDERR "$ts $level $msg\n";
314
 
      }
315
 
      else {
316
 
         print STDOUT "$ts $level $msg\n";
317
 
      }
318
 
   }
319
 
 
320
 
   return;
321
 
}
322
 
 
323
 
sub _queue_log_entry {
324
 
   my ($self, $ts, $log_level, $n_lines, $msg) = @_;
325
 
   print "$ts,$log_level,$n_lines,$msg\n";
326
 
   return;
327
 
}
328
 
 
329
 
sub _d {
330
 
   my ($package, undef, $line) = caller 0;
331
 
   @_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
332
 
        map { defined $_ ? $_ : 'undef' }
333
 
        @_;
334
 
   print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
335
 
}
336
 
 
337
 
no Lmo;
338
 
1;
339
 
# ###########################################################################
340
 
# End Percona::Agent::Logger package
341
 
# ###########################################################################