#! /usr/bin/perl

use strict;
use warnings;

use Getopt::Long;
use Log::Dispatch::Scribe;
use Pod::Usage;

my @cat_re;
my %args = (
    host => 'localhost',
    port => 1463,
    level => 'info',
    'retry-plan-a' => 'buffer',
    'retry-plan-b' => 'discard',
    'retry-buffer-size' => 100000,
    'retry-count' => 100,
    'retry-delay' => 10,
    'category-re' => sub { my ($name, $key, $value) = @_; push(@cat_re, [ $key, $value ]); },
);

GetOptions(\%args,
	   'category=s',
	   'category-re=s%',
	   'port=i',
	   'host=s',
	   'level=s',
	   'retry-plan-a=s',
	   'retry-plan-b=s',
	   'retry-buffer-size=i',
	   'retry-count=i',
	   'retry-delay=i',
	   'debug:s',
	   "help|?",
    ) or pod2usage(-exitval => 2, -verbose => 0);

pod2usage(-exitval => 0, -verbose => 2) if $args{'help'};

my $dbg_file;
my $debug;
if (defined $args{debug}) {
    $debug++;
    if ($args{debug}) {
	open($dbg_file, '>', $args{debug}) or die "Failed to open debug file $args{debug}: $!";
    }
    else {
	$dbg_file = \*STDERR;
    }
    select($dbg_file);
    $| = 1;
}

my $log = Log::Dispatch::Scribe->new(
    name       => 'scribe',
    min_level  => $args{level},
    host       => $args{host},
    port       => $args{port},
    default_category => $args{category},
    retry_plan_a => $args{'retry-plan-a'},
    retry_plan_b => $args{'retry-plan-b'},
    retry_buffer_size => $args{'retry-buffer-size'},
    retry_count => $args{'retry-count'},
    retry_delay => $args{'retry-delay'},
    );


my $extract_cat;
if (@cat_re > 0) {
    # compile a sub to evaluate the regexp matches and substitutions
    my $s = q&
$extract_cat = sub {
   my $line = shift;
&;
    for (@cat_re) {
	my ($sub, $val) = @$_;
	$val =~ s/([{}#])/\\$1/g; # escape meaningful characters
	$s .= qq&
   if (\$line =~ m{$val} ) {
     my \$ret = "$sub";
     chomp \$ret;
     return \$ret;
   }
&;
    }
    $s .= q&
   return;
}
&;
    print $dbg_file $s if $debug;
    eval $s;
}

while (my $line = <>) {
    my $cat;
    $cat = $extract_cat->($line) if defined $extract_cat;

    print $dbg_file ($cat || '') . ' ' . $line if $debug;
    $log->log( level => $args{level}, message => $line, category => $cat );
}

__END__

=head1 NAME 

scribe_cat.pl - Reads log messages from standard input and sends to a scribe instance

=head1 SYNOPSIS

  scribe_cat.pl --host=HOST --port=PORT --level=LEVEL --category=CATEGORY

  # Example Apache CustomLog entry
  CustomLog "|scribe_cat.pl --category=www" "%h %l %u %t \"%r\" %>s %b \"%{Referer}i\" \"%{User-agent}i\""

=head1 DESCRIPTION

A simple script that uses the functionality of Log::Dispatch::Scribe
to read from standard input and send to a scribe instance.  Offers
categorisation by regular expression match on the log message.

=head2 Apache Logging

This script is suitable for use with Apache httpd for piped logging
per the CustomLog example shown above.

Note that special characters in the command given in the Apache configuration file need to be escaped; for example, this command line:

  /usr/local/bin/scribe_cat.pl --category-re 'local$1= /\?p=([^ ]+)'

would be specified in the configuration file as:

  CustomLog "|/usr/local/bin/scribe_cat.pl --category-re \'local$1= /\\\\?p=([^ ]+)\'" combined

=head1 OPTIONS

=over 4

=item --host, --port

Host and port of Scribe server.  Defaults to localhost, port 1463.

=item --category=CATEGORY

Default Scribe logging category, used where there is no --category-re or no match on any given category-re.

=item --category-re CATEGORY=REGEXP [ --category-re CATEGORY=REGEXP ...]

Specify a mapping from regular expression match on each log message to
category name.  --category-re may be specified more than once to
specify a set of mappings.  Each mapping is of the form
CATEGORY=REGEXP, where CATEGORY is the category name and may include
substitutions from the matching expression, using $1, $2 etc. REGEXP
is any Perl regexp, using () for grouping to create the $1, $2
references.

The regular expressions are tried in the order that they are specified
on the command line, and the first match is used.

Example: 

    --category-re 'foo$1=www\.([^ ]+)' --category-re bar=BAR --category-re baz='(?i:BAZ)'

  Log Message       |     Category  |     Notes
  --------------------------------------------------
  www.acme.com xyz  | fooacme.com   | Back-subst of acme.com
  my new BAR baz    | bar           | Matches BAR before BAZ
  bar my new baz    | baz           | Case insensitive match on bar


=item --retry-plan-a=MODE, --retry-plan-b=MODE, --retry-buffer-size=SIZE, --retry-count=COUNT, --retry-delay=DELAY

See L<Log::Dispatch::Scribe> for full description of these options.

=item --debug, --debug=FILE

Enable debugging to standard error or to file.

=back

=head1 SEE ALSO

L<Log::Dispatch::Scribe>, L<File::Tail::Scribe>

Apache httpd piped log documentation, L<http://httpd.apache.org/docs/2.2/logs.html#piped>

=head1 AUTHOR

Jon Schutz, C<< <jon at jschutz.net> >> L<http://notes.jschutz.net>

=head1 BUGS

Please report any bugs or feature requests to
C<bug-log-logdispatch-scribe at rt.cpan.org>, or through the web
interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Log-Dispatch-Scribe>.
I will be notified, and then you'll automatically be notified of
progress on your bug as I make changes.




=head1 SUPPORT

You can find documentation for this module with the perldoc command.

    perldoc scribe_cat.pl


You can also look for information at:

=over 4

=item * RT: CPAN's request tracker

L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Log-Dispatch-Scribe>

=item * AnnoCPAN: Annotated CPAN documentation

L<http://annocpan.org/dist/Log-Dispatch-Scribe>

=item * CPAN Ratings

L<http://cpanratings.perl.org/d/Log-Dispatch-Scribe>

=item * Search CPAN

L<http://search.cpan.org/dist/Log-Dispatch-Scribe/>

=back


=head1 COPYRIGHT & LICENSE

Copyright 2009 Jon Schutz, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.


=cut