lire 2:2.1.1-2.1 / usr / share / perl5 / Lire / LrCommand.pm

package Lire::LrCommand;

use strict;

use Lire::Config;
use Lire::Config::Build qw/ac_info/;
use Lire::ReportConfig;
use Lire::PluginManager;
use Lire::DlfStore;
use Lire::ImportJob;
use Lire::OutputJob;
use Lire::DlfConverterProcess;
use Lire::Utils qw/check_param check_object_param tempdir/;
use Lire::Error qw/file_not_writable file_not_readable/;
use File::Path qw/rmtree/;

use POSIX qw/:locale_h/;
use File::Basename;
use File::Copy qw/copy/;
use Locale::TextDomain 'lire';
use Text::Wrap qw/ wrap /;
use Carp;
use Getopt::Long;

=pod

=head1 NAME

Lire::LrCommand - Base class for command line programs.

=head1 SYNOPSIS

  my $prog = new Lire::LrCommand();
  $prog->init();
  $prog->add_section( 'myprog', __( 'My Program Options' ) );
  $prog->add_option( 'name' => 'myoption', 'type' => '=s',
                     'help' => __( 'My option help.' ) );
  $prog->add_common_options();
  $prog->parse_options();

=head1 DESCRIPTION

Class which is used to create command line program which shares
functionaliy.

=head1 METHODS

=head2 new( [$usage], [$help] )

Creates a new Lire::LrCommon instance. Initializes the usage string
and the help message to $usage and $help.

=cut

sub new {
    my ( $class, $usage, $help ) = @_;

    my $self = bless {}, $class;
    $self->{'_prog'} = basename( $0 );
    $self->{'_options'} = {};
    $self->{'_sections'} = [];
    $self->{'_section_labels'} = {};
    $self->{'_cfg'} = {};
    $self->{'_usage'} = $usage || '';
    $self->{'_help'} = $help || '';
    return $self;
}

sub init {
    my $self = $_[0];

    setlocale( LC_ALL, '' );

    $SIG{'__WARN__'} = sub { $self->warning( @_ ); };
    foreach my $name ( qw|.lire .lire/converters .lire/plugins .lire/reports
                          .lire/filters .lire/schemas .lire/templates| )
    {
        my $dir = "$ENV{'HOME'}/$name";
        unless ( -d $dir  ) {
            mkdir $dir
              or $self->error( __x( 'Cannot create directory {directory}.',
                                    'directory' => $dir ) );
            $self->info( __x( 'Created {directory}.',
                              'directory' => $dir ) );
        }
    }
    Lire::Config->init();
    Lire::PluginManager->register_default_plugins();
    $self->{'_tmpdir'} = tempdir( $self->{'_prog'} . '_XXXXXX' );
    $self->{'_keepdir'} = Lire::Config->get( 'lr_keep' );

    $SIG{'PIPE'} = 'IGNORE';

    return;
}

sub DESTROY {
    my $self = $_[0];

    if ( $self->{'_keepdir'} ) {
        $self->info( __x( 'Keeping temporary directory {tmpdir}',
                          'tmpdir' => $self->{'_tmpdir'} ) );
    } else {
        rmtree( $self->{'_tmpdir'} );
    }
    return;
}

=pod

=head2 set_usage( [$usage] )

=cut

sub set_usage {
    my ( $self, $usage ) = @_;

    $self->{'_usage'} = $usage;

    return;
}

=pod

=head2 set_help( [$help] )

=cut

sub set_help {
    my ( $self, $help ) = @_;

    $self->{'_help'} = $help;

    return;
}

=pod

=head2 set_section( [$name], [$label] )

=cut

sub add_section {
    my ( $self, $name, $label ) = @_;
    check_param( $name, 'name' );
    check_param( $label, 'label' );
    push @{$self->{'_sections'}}, $name;
    $self->{'_section_labels'}{$name} = $label;
    return;
}

=pod

=head2 add_option( [%args] )

=cut

sub add_option {
    my ( $self, %args ) = @_;

    check_param( $args{'name'}, 'name' );
    check_param( $args{'section'}, 'section' );
    my $section = $args{'section'};
    croak "invalid section: $section"
      unless exists $self->{'_section_labels'}{$section};
    check_param( $args{'help'}, 'help' );
    check_object_param( $args{'aliases'}, 'aliases', 'ARRAY' )
      if defined $args{'aliases'};
    $args{'aliases'} = [] unless defined $args{'aliases'};
    $args{'type'} = '' unless defined $args{'type'};
    $args{'action'} = 'store' unless defined $args{'action'};

    $self->{'_options'} ||= [];
    push @{$self->{'_options'}{$section}}, \%args;

    return;
}

=pod

=head2 add_common_options()

=cut

sub add_common_options {
    my $self = $_[0];

    $self->add_section( 'common', __( 'Common options' ) );
    $self->add_option( 'name' => 'help',
                       'type' => ':s',
                       'section' => 'common',
                       'action' => sub { $self->do_help( $_[1] ) },
                       'help' => __( 'Print usage information and exit. If "report-templates", "output-formats" or "dlf-converters" is given as argument, the command will print an information list for that object type.' ),
                     );
    $self->add_option( 'name' => 'version',
                       'section' => 'common',
                       'action' => sub { $self->do_version() },
                       'help' => __( 'Print Lire version and exit.' ),
                     );
    $self->add_option( 'name' => 'quiet',
                       'type' => '!',
                       'section' => 'common',
                       'help' => __( 'Only print errors.' ),
                     );
    return;
}

sub add_email_options {
    my $self = $_[0];

    $self->add_section( 'email', __( 'Email related options' ) );
    $self->add_option( 'name' => 'subject',
                       'section' => 'email',
                       'help' => __( "Sets the email's subject." ),
                       'type' => '=s' );
    $self->add_option( 'name' => 'extra-file',
                       'type' => '=s',
                       'section' => 'email',
                       'help' => __( 'A text file that will be included with the report.' ),
                     );

    return;
}

sub add_output_format_options {
    my $self = $_[0];

    $self->add_section( 'output', __( 'Output format options' ) );
    $self->add_option( 'name' => 'image',
                       'section' => 'output',
                       'help' => __( 'Backward compatibility.' ),
                       'obsolete' => 1 );
    $self->add_option( 'name' => 'output-format',
                       'type' => '=s',
                       'section' => 'output',
                       'help' => __( 'Select the output format. Default to "txt"' ),
                     );

    return;
}

sub add_merging_options {
    my $self = $_[0];

    $self->add_section( 'merging', __( 'Merging options' ) );
    $self->add_option( 'name' => 'template',
                       'section' => 'merging',
                       'type' => '=s',
                       'help' => __( 'Select the report configuration template that should be used for merging the reports. This option is required if you use the --merge option.' ),
                     );
    $self->add_option( 'name' => 'merge',
                       'section' => 'merging',
                       'aliases' => [ 'x' ],
                       'type' => '=s@',
                       'help' => __( 'Merge an additional report before formatting the report. This option can be used multipe times.' ),
                     );
    $self->add_option( 'name' => 'report-cfg',
                       'type' => '=s',
                       'section' => 'merging',
                       'aliases' => [ 'c' ],
                       'help' => __( 'Pre Lire 2.0 report configuration file.' ),
                       'obsolete' => 1 );
    $self->add_option( 'name' => 'U',
                       'type' => '=s',
                       'section' => 'merging',
                       'help' => __( 'Selects the superservice for which the report configuration file is made.' ),
                       'obsolete' => 1 );

    return;
}

sub add_report_options {
    my $self = $_[0];

    $self->add_section( 'report', __( 'Report generation options' ) );
    $self->add_option( 'name' => 'report-cfg',
                       'type' => '=s',
                       'section' => 'report',
                       'aliases' => [ 'c' ],
                       'help' => __( 'Pre Lire 2.0 report configuration file.' ),
                       'obsolete' => 1 );
    $self->add_option( 'name' => 'template',
                       'section' => 'report',
                       'type' => '=s',
                       'help' => __( 'Select the report configuration template that should be used for generating the report.' ),
                     );
    return;
}

sub get_option {
    my ( $self, $name, $default ) = @_;

    check_param( $name, 'name' );

    return defined $self->{'_cfg'}{$name} ? $self->{'_cfg'}{$name} : $default;
}

sub parse_options {
    my $self = $_[0];

    my @options = ();
    foreach my $section ( @{$self->{'_sections'}} ) {
        foreach my $opt ( @{$self->{'_options'}{$section}} ) {
            my $spec = join ( "|", $opt->{'name'}, @{$opt->{'aliases'}} ) 
              . $opt->{'type'};
            $self->{'_cfg'}{$opt->{'name'}} = $opt->{'action'}
              if ref $opt->{'action'};
            push @options, $spec;
        }
    }
    GetOptions( $self->{'_cfg'}, @options )
      or $self->usage();
    return;
}

sub error {
    my ( $self, @msgs ) = @_;

    print STDERR $self->{'_prog'} . ': ' . __( 'ERROR ' ),
      join( "\n", @msgs ), "\n";

    exit(1);
}

sub warning {
    my ( $self, @msgs ) = @_;

    return if $self->{'_cfg'}{'quiet'};

    print STDERR $self->{'_prog'} . ': ' . __( 'WARNING ' ),
      join( "\n", @msgs ), "\n";

    return;
}

sub info {
    my ( $self, @msgs ) = @_;

    return if $self->{'_cfg'}{'quiet'};

    print STDERR join( "\n", @msgs ), "\n";

    return;
}

sub do_version {
    my $self = $_[0];

    print STDERR __x( '{program} as shipped with Lire version {version}',
                      'program' => $self->{'_prog'},
                      'version' => ac_info( 'VERSION' ) ), "\n";
    exit(0);
}

sub usage {
    my ( $self, $msg ) = @_;

    if ( $msg ) {
        chomp $msg;
        print STDERR $msg, "\n"
          if $msg;
    }
    $self->print_usage();
    exit(1);
}

sub print_usage {
    my $self = $_[0];

    print STDERR __x( 'Usage: {program} {usage}', 
                      'program' => $self->{'_prog'},
                      'usage' => $self->{'_usage'} ), "\n";
    return;
}

sub do_help {
    my ( $self, $section ) = @_;

    $section ||= '';
    if ( $section eq 'output-formats' ) {
        $self->do_help_output_formats();
    } elsif ( $section eq 'report-templates' ) {
        $self->do_help_report_templates();
    } elsif ( $section eq 'dlf-converters' ) {
        $self->do_help_dlf_converters();
    } elsif ( $section ) {
        print STDERR __x( 'Unknown help section: {section}',
                          'section' => $section ), "\n";
    }
    $self->print_usage();
    print STDERR "\n", wrap( '', '', $self->{'_help'} ), "\n", "\n";
    foreach my $section ( @{$self->{'_sections'} } ) {
        print STDERR uc $self->{'_section_labels'}{$section}, "\n";
        foreach my $option ( @{$self->{'_options'}{$section}} ) {
            my $obsolete = $option->{'obsolete'} ? ' ' .
              __( 'This option is obsolete.' ) : '';
            print wrap( sprintf( '  --%-17s', $option->{'name'} ) . ' ',
                        ' ' x 22, $option->{'help'} . $obsolete ), "\n";
        }
        print "\n";
    }
    exit(0);
}

sub do_help_report_templates {
    my $self = $_[0];

    print STDERR __( 'Available report templates:' ), "\n";
    foreach my $template ( sort @{Lire::ReportConfig->templates()} ) {
        print STDERR $template, "\n";
    }
    exit(0);

}

sub do_help_dlf_converters {
    my $self = $_[0];

    print STDERR __( 'Available DLF converters:' ), "\n";
    my @plugins = sort { $a->name() cmp $b->name() }
      @{Lire::PluginManager->plugins( 'dlf_converter' )};
    foreach my $converter ( @plugins ) {
        printf STDERR "%-16s %s\n", $converter->name(), $converter->title();
    }

    exit(0);
}

sub do_help_output_formats {
    my $self = $_[0];

    print STDERR __( 'Available output formats:' ), "\n";
    my @plugins = sort { $a->name() cmp $b->name() } 
      @{Lire::PluginManager->plugins( 'output_format' )};
    foreach my $format ( @plugins ) {
        printf STDERR "%-16s %s\n", $format->name(), $format->title();
    }

    exit(0);
}

sub init_temp_store {
    my $self = $_[0];

    $self->{'_store'} = eval {
        Lire::DlfStore->open( "$self->{'_tmpdir'}/store", 1 );
    };
    $self->error( $@ ) if $@;

    return;
}

sub is_compressed {
    my ( $self, $magic ) = @_;

    return unless length $magic;

    if ( substr($magic,0,2) eq "\037\235" ) {
        return 'compress';
    } elsif ( substr($magic,0,2) eq "\037\213" ) {
        return 'gzip';
    } elsif ($magic eq "PK\003\004" ) {
        return 'PKZIP';
    }

    return;
}

sub handle_logfile {
    my ( $self, $logfile ) = @_;

    $self->{'_logfile'} = $logfile;
    open my $fh, $logfile
      or $self->error( file_not_readable( $logfile ) );

    my $magic;
    read $fh, $magic, 4;
    $self->error( __x( 'read failed: {error}', 'error' => $! ) )
      unless defined $magic;
    my $algo = $self->is_compressed( $magic );
    my $tmplogfile = "$self->{'_tmpdir'}/logfile";
    my $out_fh;
    if ( $algo ) {
        $self->info( __x( 'Log file was compressed using {algo}.',
                          'algo' => $algo ) );
        $self->error( __( "gzip(1) isn't available" ) )
          unless Lire::Config->get_var( 'gzip_path' )->is_valid();
        my $gzip = Lire::Config->get( 'gzip_path' );
        $self->info( __x( 'Decompressing log file using {gzip}...',
                          'gzip' => $gzip ) );
        local %ENV = ();
        open $out_fh, "|$gzip -d > $tmplogfile"
          or $self->error( __x( 'error forking: {error}', 'error' => $! ) );
    } elsif ( $logfile eq '-' or $logfile =~ /\|\s*$/ ) {
        open $out_fh, "> $tmplogfile"
          or $self->error( file_not_writable( $tmplogfile ) );
    }
    if ( $out_fh ) {
        $self->{'_logfile'} = $tmplogfile;
        print $out_fh $magic;
        my $buffer;
        while ( read $fh, $buffer, 1024**2 ) {
            print $out_fh $buffer;
        }
        $self->error( __x( 'read failed: {error}', 'error' => $! ) )
          unless defined $buffer;
        close $out_fh
          or $self->error( __x( "gzip exited with non zero status: {status}",
                                'status' => $? ) );
    }
    close $fh;
    return;
}

=pod

=head2 import_log( [$converter], [$logfile] )

import_log invokes Lire::ImportJob and Lire::DlfConverterProcess.
It uses &handle_logfile.

This means that in case the $logfile is compressed, it is decompressed to a
file in $TMPDIR.  In case the $logfile is read from a pipe or from STDIN, it is
written to a file in $TMPDIR.  So, if you're short on discspace, pass the
logfile as an uncompressed file.

=cut

sub import_log {
    my ( $self, $converter, $logfile ) = @_;

    $self->check_converter( $converter );
    $self->handle_logfile( $logfile );
    $self->info( __x( 'Parsing log file using {converter} DLF Converter...',
                      'converter' => $converter ) );
    eval {
        my $src = new Lire::ImportJob( "lr_store",
                                       pattern => $self->{'_logfile'},
                                       period => 'unique',
                                       converter => $converter );
        my $process = new Lire::DlfConverterProcess( $src, $self->{'_store'} );
        $process->run_import_job();
        $self->info( __x( 'Extracted {dlf_count} DLF records on {line_count} lines.',
                          'dlf_count' => $process->dlf_count(),
                          'line_count' => $process->line_count() ) );
        $self->info( __x( 'Encountered {error_count} errors and ignored {ignored_count} lines.',
                          'error_count' => $process->error_count(),
                          'ignored_count' => $process->ignored_count() ) );
    };
    $self->error( $@ ) if $@;

    return;
}

sub init_report_config {
    my ( $self, $converter ) = @_;

    if ( $self->{'_cfg'}{'template'} ) {
        $self->{'_report_cfg'} = $self->load_report_config_from_template();
    } elsif ( $self->{'_cfg'}{'report-cfg'} ) {
        $self->{'_report_cfg'} =
          eval { new_from_file Lire::ReportConfig( $self->find_superservice( $converter ), $self->{'_cfg'}{'report-cfg'} ) };
        $self->error( $@ ) if $@;
    } else {
        my $template =  $self->find_superservice( $converter) . '_default';
        $self->error( __x( 'No default report configuration template defined for DLF converter "{converter}.".', 'converter' => $converter,
                           'template' => $template ),
                      __(  'Use the --template option.' ) )
          unless Lire::ReportConfig->has_template( $template );
        $self->{'_report_cfg'} = Lire::ReportConfig->template( $template )->as_value();
    }

    return;
}

sub check_converter {
    my ( $self, $converter ) = @_;

    $self->error( __x( 'No such DLF converter: {converter}.',
                       'converter' => $converter ),
                  __( 'Use --help dlf-converters to list available converters' ) )
      unless Lire::PluginManager->has_plugin( 'dlf_converter', $converter );

    return;
}

sub find_superservice {
    my ( $self, $converter ) = @_;

    $self->check_converter( $converter );
    my $plugin = Lire::PluginManager->get_plugin( 'dlf_converter', $converter);
    return ($plugin->schemas())[0];
}

=pod

=head2 generate_report( [$converter], [$logfile] )

Generate a report from a $logfile, using $converter.  Returns $reportfile.
Uses Lire::ReportConfig::generate_report to do the real work.

=cut

sub generate_report {
    my ( $self, $converter, $logfile ) = @_;

    check_param( $converter, 'converter' );
    check_param( $logfile, 'logfile' );

    $self->init_temp_store();
    $self->init_report_config( $converter );
    $self->import_log( $converter, $logfile );

    $self->info( __( 'Running analysers...' ) );
    my $cfg = $self->{'_report_cfg'};
    eval { $cfg->create_analyser_streams( $self->{'_store'} ) };
    $self->error( $@ ) if $@;

    $self->info( __( 'Generating XML report...' ) );
    my $report = eval { $cfg->generate_report( $self->{'_store'} ) };
    $self->error( $@ ) if $@;

    my $reportfile = "$self->{'_tmpdir'}/report.xml";
    open my $fh, "> $reportfile"
      or $self->error( file_not_writable( $reportfile ) );

    eval {
        $report->write_report( $fh );
        $fh->close();
    };
    $self->error( $@ ) if $@;

    return $reportfile;
}

sub load_report_config_from_template {
    my $self = $_[0];

    my $name = $self->{'_cfg'}{'template'};
    $self->error( __x( 'No report configuration template: {template}.',
                       'template' => $name ),
                  __( 'Use --help report-templates to list available templates.',  ) )
      unless Lire::ReportConfig->has_template( $name );

    return Lire::ReportConfig->template( $name )->as_value();
}

sub init_merging_report_config {
    my $self = $_[0];

    if ( $self->{'_cfg'}{'template'} ) {
        return $self->load_report_config_from_template();
    } elsif ( $self->{'_cfg'}{'report-cfg'} ) {
        $self->error( __( 'The -U option is required with --report-cfg' ) )
          unless $self->{'_cfg'}{'U'};
        return eval { new_from_file Lire::ReportConfig( $self->{'_cfg'}{'U'}, $self->{'_cfg'}{'report-cfg'} ) };
        $self->error( $@ ) if $@;
    } else {
        $self->error( __( 'You need to use the --template option to merge reports.' ) );
    }
}

sub merge_reports {
    my ( $self, $report ) = @_;

    return $report
      unless $self->{'_cfg'}{'merge'};

    my @reports = ( $report, @{$self->{'_cfg'}{'merge'}} );
    my $cfg = $self->init_merging_report_config();
    my $tmpreport = "$self->{'_tmpdir'}/merged-report.xml";
    $self->info( __x( "Merging reports '{reports}'...",
                      'reports' => join "', '", @reports ) );
    eval {
        my $report = $cfg->merge_report_files( @reports );

        open my $fh, "> $tmpreport"
          or $self->error( file_not_writable( $tmpreport ) );
        $report->write_report( $fh );
        close $fh;
    };
    $self->error( $@ ) if $@;

    return $tmpreport;
}

sub check_output_format {
    my $self = $_[0];

    $self->{'_cfg'}{'output-format'} ||= 'txt';

    my $format = $self->{'_cfg'}{'output-format'} ||= 'txt';
    $self->error( __x( 'No such output format: {format}.',
                       'format' => $format ),
                  __( 'Use --help output-formats to list available formats.') )
      unless Lire::PluginManager->has_plugin( 'output_format', $format );

    my $plugin = Lire::PluginManager->get_plugin( 'output_format', $format );
    my $missings = join "\n", $plugin->missing_requirements();
    $self->error( __( 'This output format has missing requirements:' ),
                  $missings )
      if $missings;
    return;
}

sub format_report {
    my ( $self, $report_file, $output_file ) = @_;

    check_param( $report_file, 'report_file' );
    check_param( $output_file, 'output_file' );

    eval {
        my $format = $self->{'_cfg'}{'output-format'};
        $self->info( __x( 'Formatting report as {format} in {file}...',
                          'format' => $format,
                          'file' => $output_file ) );

        my $stdout = 0;
        if ( $output_file eq '-' or $output_file =~ /\|\s*/ ) {
            $output_file = "$self->{'_tmpdir'}/formatted-report.$format";
            $stdout = 1;
        }
        my $job = new Lire::OutputJob( 'file', Lire::PluginManager->get_plugin( 'output_format', $format ), {}, 'file' => $output_file );
        $job->run( $report_file );

        if ( $format eq 'html' && $stdout ) {
            my $tar = Lire::Config->get( 'tar_path' );
            system ( "$tar cC $self->{'_tmpdir'} report" );
        } elsif ( $stdout ) {
            copy( $output_file, \*STDOUT );
        }
    };
    $self->error( $@ ) if $@;

    return;
}

sub check_email_requirements {
    my $self = $_[0];

    eval "use MIME::Entity;";
    $self->error( __( 'This command requires the MIME::Tools CPAN module.' ) )
      if $@;

    return;
}

sub email_report {
    my ( $self, $report_file, @emails ) = @_;

    check_param( $report_file, 'report_file' );

    eval {
        my $format = $self->{'_cfg'}{'output-format'};
        my $subject = $self->{'_cfg'}{'subject'}
          || __x( 'Your {format} report.', 'format' => $format );
        $self->info( __x( 'Formatting report as {format} and emailing it to {emails}...',
                          'format' => $format,
                          'emails' => join( ", ", @emails ) ), );

        my $plugin = 
          Lire::PluginManager->get_plugin( 'output_format', $format );
        my $job = new Lire::OutputJob( 'email', $plugin, {},
                                       'subject' => $subject,
                                       'extra_file' => $self->{'_cfg'}{'extra-file'},
                                       'emails' => \@emails );
        $job->run( $report_file );
    };
    $self->error( $@ ) if $@;

    return;
}

1;


__END__

=pod

=head1 SEE ALSO

lr_log2report(1), lr_log2mail(1), lr_xml2mail(1), lr_xml2report(1),
Lire::Config(3pm), Lire::ReportConfig(3pm), Lire::PluginManager(3pm),
Lire::DlfStore(3pm), Lire::ImportJob(3pm), Lire::OutputJob(3pm),
Lire::DlfConverterProcess(3pm)

=head1 AUTHOR

  Francis J. Lacoste <flacoste@logreport.org>

=head1 VERSION

$Id: LrCommand.pm,v 1.9 2006/07/23 13:16:29 vanbaal Exp $

=head1 COPYRIGHT

Copyright (C) 2004 Stichting LogReport Foundation LogReport@LogRepor
t.org

This file is part of Lire.

Lire is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program (see COPYING); if not, check with
http://www.gnu.org/copyleft/gpl.html.

=cut