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

package Lire::ReportConfig;

use strict;

use Text::ParseWords qw/ shellwords /;

use Lire::DlfSchema;
use Lire::ReportSpec;
use Lire::FilterSpec;
use Lire::FilterExpr;
use Lire::I18N qw/ set_fh_encoding /;
use Lire::Report;
use Lire::ReportSection;
use Lire::DlfAnalyserProcess;
use Lire::ReportParser::ReportBuilder;
use Lire::Utils qw/check_param check_object_param /;
use Lire::Config;
use Lire::Config::ReportSpec;
use Lire::Config::SpecParser;
use Lire::Error qw/ directory_not_readable /;
use Carp;

=pod

=head1 NAME

Lire::ReportConfig - API to the report configuration file

=head1 SYNOPSIS

    use Lire::ReportConfig;

    my $templates = Lire::ReportConfig->templates();
    if ( Lire::ReportConfig->has_template( 'www_default' ) ) {
        my $report_cfg = Lire::ReportConfig->template( 'www_default' )->as_value();
        my $report = $report_cfg->generate_report( $report );
    }

=head1 DESCRIPTION

This class represents report configurations. Report configurations are
stored as an XML configuration using the Lire::Report::ReportSpec
configuration type.

=head1 TEMPLATES

Template reports are configuration specification files found in the
directories specified by the 'lr_templates_path' configuration
variable.

=head2 templates()

Returns an array reference containing the names of all defined
templates.

=cut

our %TEMPLATES = ();

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

    my %templates = map { $_ => 1} keys %TEMPLATES;
    foreach my $dir ( @{ Lire::Config->get( 'lr_templates_path' ) } ) {
        opendir my $dh, $dir
          or die directory_not_readable( $dir ), "\n";
        foreach my $name ( readdir $dh ) {
            next unless $name =~ /^([-.\w]+)\.xml$/;
            $templates{$1} = 1;
        }
        closedir $dh;
    }

    return [ keys %templates ];
}

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

    foreach my $dir ( @{ Lire::Config->get( 'lr_templates_path' ) } ) {
        return "$dir/$name.xml" if -f "$dir/$name.xml";
    }

    return undef;
}

=pod

=head2 has_template( $name )

Returns true if there is a template named $name available.

=cut

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

    check_param( $name, 'name' );
    return 1 if exists $TEMPLATES{$name};

    return defined $self->_find_template_file( $name );
}

=pod

=head2 template( $name )

Returns a Lire::Config::Object defining the template ReportConfig
named $name. Its spec() method would return a Lire::Config::ReportSpec
object and its as_value() method would instantiate a
Lire::ReportConfig object.

=cut

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

    check_param( $name, 'name' );
    return $TEMPLATES{$name} if exists $TEMPLATES{$name};

    my $file = $self->_find_template_file( $name );
    croak "no template named '$name' found in lr_templates_path"
      unless defined $file;

    my $parser = new Lire::Config::SpecParser();
    my $spec = $parser->parsefile( $file );
    croak "error in template file '$file', there is no component named '$name'"
      unless $spec->has_component( $name );

    return $TEMPLATES{$name} = $spec->get( $name )->instance();
}

=pod

=head1 CONSTRUCTORS

=head2 new()

This creates a new empty Lire::ReportConfig object.

The created report configuration object doesn't contain any section,
report or filter specifications.

=cut

sub new {
    return bless {
                  '_sections'     => [],
                  '_encoding'    => undef,
                  '_filename'    => undef,
                  '_title'       => undef,
                 }, shift;
}

=pod

=head2 new_from_file( $superservice, $report_cfg )

This will create a new report configuration object for the
$superservice superservice based on the report configuration file
$report_cfg.

=cut

sub new_from_file {
    my ( $class, $superservice, $report_cfg ) = @_;

    check_param( $superservice, 'superservice',
                 sub { Lire::DlfSchema->has_superservice( $_[0] ) },
                 'invalid superservice' );

    my $self = $class->new();

    $self->_load_from_file( $superservice, $report_cfg );

    return $self;
}

sub new_from_config {
    my ( $self, $value ) = @_;

    my $def = $value->Lire::Config::Dictionary::as_value();

    my $cfg = new Lire::ReportConfig();
    $cfg->title( $def->{'title'} )
      if $def->{'title'};

    foreach my $section ( @{$def->{'sections'}} ) {
        $cfg->add_section( $section );
    }

    return $cfg;
}

=pod

=head1 OBJECT METHODS

=pod

=head2 filename( [ $new_filename ] )

Returns (and optionanly changes) the filename from which this
ReportConfig was loaded. It will return undef if the ReportConfig
wasn't loaded from a file.

=cut

sub filename {
    $_[0]{'_filename'} = $_[1] if @_ == 2;
    return $_[0]{'_filename'};
}

=pod

=head2 title( [ $new_title ] )

Returns (and optionnally changes) the title that will be assigned to
the report.

=cut

sub title {
    my ( $self, $new_title ) = @_;

    $self->{'_title'} = $new_title
      if @_ == 2;

    return $self->{'_title'};
}

sub _load_from_file {
    my ( $self,$superservice,  $report_cfg ) = @_;

    # Reset the sections
    $self->{'_sections'} = [];

    # Format of the configuration file is
    # ((=section <title>)
    #  (|filter_id <param>)*
    #  (report_id  <param>))*)+

    $self->{'_curr_section'}  = undef;
    $self->{'_id_cache'} = {};

    # Load the report configuration file
    open my $fh, $report_cfg
      or die "can't open report configuration file $report_cfg: $!\n";
    $self->{'_fh'} = $fh;

    my $line;
    while ( defined( $line = <$fh> ) ) {
        next if $line =~ /^\s*#/; # Skip comments
        next if $line =~ /^\s*$/; # Skip blank lines

        chomp $line;

        my $first_char = substr( $line, 0, 1 );
        if ( $first_char eq '=' ) {
            if ( $line =~ /^=encoding/ ) {
                $self->_parse_encoding_line( $line );
            } elsif ( $line =~ /^=section/ ) {
                $self->_parse_section_line( $superservice, $line );
            } else {
                warn "Unknown directive at line $.: $line\n";
            }
        } elsif ( $first_char eq '|' ) {
            $self->_parse_filter_line( $superservice, $line );
        } else {
            $self->_parse_report_line( $superservice, $line );
        }
    }
    close $fh;

    delete $self->{'_fh'};
    delete $self->{'_curr_section'};
    delete $self->{'_id_cache'};

    $self->{'_filename'} = $report_cfg;
    return;
}

sub _parse_encoding_line {
    my ( $self, $line ) = @_;

    die "'encoding' directive requires perl >= 5.8.0, at line $.\n"
      unless $Lire::I18N::USE_ENCODING;

    die "'encoding' directive must be the first directive, at line $.\n"
      if ( defined $self->{'_curr_section'} );
    die "only one 'encoding' directive allowed, at line $.\n"
      if ( defined $self->{'_encoding'} );

    $line =~ /^=encoding\s+([-\w.]+)$/;
    die "invalid 'encoding' directive, at line $.\n"
      unless ( defined $1 );
    $self->{'_encoding'} = $1;

    set_fh_encoding( $self->{'_fh'}, $1 );

    return;
}

sub _parse_section_line {
    my ( $self, $superservice, $line ) = @_;

    unless ( $line =~ /^=section (.*)$/ ) {
        warn "invalid section directive at line $.: $line";
        return;
    }

    $self->{'_curr_section'} = new Lire::ReportSection( $superservice, $1 );
    $self->add_section( $self->{'_curr_section'} );

    return;
}

sub _parse_filter_line {
    my ( $self, $superservice, $line ) = @_;

    my ( $id, $params ) = _parse_param_line( substr( $line, 1 ) );
    eval {
        die "filter specification before any =section directive\n"
          unless $self->{'_curr_section'};
        die"filter specification should come before report specifications\n"
          if $self->{'_curr_section'}->reports();

        my $spec = Lire::FilterSpec->load( $superservice, $id );

        while ( my ($name, $value) = each %$params ) {
            $spec->param( $name )->value( $value );
        }
        $self->{'_curr_section'}->add_filter( $spec );
    };
    if ( $@ ) {
        warn( "error at line $.: $@\n" );
        warn( "Omitting filter $id defined at line $.\n" );
    }

    return;
}

sub _parse_report_line {
    my ( $self, $superservice, $line ) = @_;

    my ( $id, $params ) = _parse_param_line( $line );

    eval {
        die "report specification before any =section directive\n"
          unless $self->{'_curr_section'};

        my $report_spec = Lire::ReportSpec->load( $superservice, $id );

        while ( my ($name, $value) = each %$params ) {
            $report_spec->param( $name )->value( $value );
        }

        $self->{'_id_cache'}{$id} ||= 0;
        $report_spec->subreport_id( $id . "." . $self->{'_id_cache'}{$id}++ );

        $self->{'_curr_section'}->add_report( $report_spec );
    };
    if ( $@ ) {
        warn( "error at line $.: $@\n" );
        warn( "Omitting report $id defined at line $.\n" );
    }

    return;
}

sub _parse_param_line {
    my ( $id, @p ) = shellwords( $_[0] );
    my %params = ();
    foreach my $param_str ( @p ) {
        my ( $param, $value ) = $param_str =~ /^([-.\w]+)=(.*)$/;
        unless ( defined $param ) {
            warn( "error parsing parameter $param_str at line $.. Ignoring parameter.\n" );
            next;
        }

        $value = "" unless defined $value;
        $params{$param} = $value;
    }

    return ( $id, \%params );
}

sub create_param_line {
    my ( $id, $spec ) = @_;

    my @line = ( $id );
    foreach my $name ( $spec->param_names() ) {
        my $value = $spec->param( $name )->value();
        $value =~ s/\\/\\\\/g;  # Escape backslashes
        $value =~ s/"/\\"/g;    # and double quotes

        push @line, $name . '="' . $value . '"';
    }
    return join( " ", @line );
}

=pod

=head2 schemas()

Returns an array reference containing the name of the schemas used
in this report.

=cut

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

    my %schemas = ();
    foreach my $section ( $self->sections() ) {
        foreach my $report ( $section->reports() ) {
            foreach my $schema ( @{$report->schemas()} ) {
                $schemas{$schema} = 1
            }
        }
    }
    return [ keys %schemas ];
}

=pod

=head2 sections()

Return's this report configuration's sections as an array of
Lire::Section objects.

=cut

sub sections {
    my ( $self ) = @_;

    return @{$self->{'_sections'}};
}

=pod

=head2 add_section( $section )

Adds a section to this report configuration. The $section parameter
should be a Lire::ReportSection object.

=cut

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

    check_object_param( $section, 'section', 'Lire::ReportSection' );
    push @{$self->{'_sections'}}, $section;

    return;
}

=pod

=head2 merge_filters()

Calling this method will make sure that all report specifications
take into account their section's filter specification.

This method will modify all report specifications. After this their
object representation won't be identical to the one in the XML report
specification.

=cut

sub merge_filters {
    my ( $self ) = @_;

    foreach my $section ( $self->sections() ) {
        my @filters = map { $_->filter_spec() } $section->filters();
        my @reports = $section->reports();

        foreach my $r ( @reports ) {
            if ( @filters ) {
                my $expr;
                if ( $r->filter_spec || @filters > 1) {
                    $expr = new Lire::FilterExpr::And( 'container' => $r );
                    if ( $r->filter_spec ) {
                        $expr->expr( [ @filters, $r->filter_spec ] );
                    } else {
                        $expr->expr( [@filters] );
                    }
                } else {
                    $expr = $filters[0];
                }
                $r->filter_spec( $expr );
            }
        }
    }

    return;
}

=pod

=head2 print( [$fh] )

Prints the report configuration on the $fh filehandle. If the $fh
parameter is omitted, the report configuration will be printed on
STDOUT.

=cut

sub print {
    my ( $self, $fh ) = @_;

    $fh ||= \*STDOUT;

    if ( defined $self->{'_encoding'} ) {
        set_fh_encoding( $fh, $self->{'_encoding'} );
        print $fh "=encoding ", $self->{'_encoding'}, "\n\n";
    }
    foreach my $section ( $self->sections() ) {
        print $fh "=section ", $section->title(), "\n";

        foreach my $filter ( $section->filters() ) {
            print $fh create_param_line( "|" . $filter->id(), $filter ), "\n";
        }

        foreach my $report ( $section->reports() ) {
            print $fh create_param_line( $report->id(), $report ), "\n";
        }

        # Empty line
        print $fh "\n"
    }
}

# Used by lr_report_cfg2xml to convert file-based 
# report configuration to the new XML format.
sub as_config_value {
    my ( $self, $name ) = @_;

    my %filters_id = ();
    check_param( $name, 'name' );
    my $spec = new Lire::Config::ReportSpec( 'name' => $name );
    my $cfg = $spec->instance();
    $cfg->get( 'id' )->set( $name );
    foreach my $section ( @{$self->{'_sections'}} ) {
        my $sect_cfg =
          $spec->get( 'sections' )->get( 'section' )->instance();
        $cfg->get( 'sections' )->append( $sect_cfg );
        $sect_cfg->get( 'superservice' )->set( $section->superservice() );
        $sect_cfg->get( 'title' )->set( $section->title() );
        foreach my $filter ( $section->filters() ) {
            my $type = $filter->id();
            my $id = $filter->superservice() . ':' . $type;
            my $filter_cfg = $sect_cfg->spec()->get( 'filters' )->get( $id )->instance();
            $filters_id{$type} ||= 0;
            $filter_cfg->get( 'id' )->set( $type . '.' . $filters_id{$type}++);
            foreach my $name ( $filter->param_names() ) {
                $filter_cfg->get( $name )->set( $filter->param( $name )->value() );
            }
            $sect_cfg->get( 'filters' )->append( $filter_cfg );
        }
        foreach my $report ( $section->reports() ) {
            my $id = $report->superservice() . ':' . $report->id();
            my $report_cfg = $sect_cfg->spec()->get( 'specs' )->get( $id )->instance();
            $report_cfg->get( 'id' )->set( $report->subreport_id() );
            foreach my $name ( $report->param_names() ) {
                $report_cfg->get( $name )->set( $report->param( $name )->value() );
            }
            $sect_cfg->get( 'specs' )->append( $report_cfg );
        }
    }

    return $cfg;
}


=pod

=head2 create_report( $timespan_start, $timespan_end )

Returns a Lire::Report object based on this report's configuration file.
The $timespan_start and $timespan_end attribute will be used to initiate
the Report object.

Used when generating an XML report from a DLF source, and
when merging XML reports.

The real job is delegated to Lire::ReportSection::create_report_section().

=cut

sub create_report {
    my ( $self, $start, $end) = @_;

    my $report = new Lire::Report();
    $report->timespan_start( $start );
    $report->timespan_end( $end );
    $report->title( $self->{'_title'} )
      if defined $self->{'_title'};
    foreach my $s ( $self->sections() ) {
        $s->create_report_section( $report );
    }

    return $report;
}

=pod

=head2 create_analyser_streams( $store )

This method will make sure that a DlfStream is available in the
Lire::DlfStore $store for each schema used by this report
configuration. The stream will be created by running the first
analyser which is able to generate the schema using exising streams.

=cut

sub create_analyser_streams {
    my ($self, $store ) = @_;

    check_object_param( $store, 'store', 'Lire::DlfStore' );

    foreach my $schema ( @{$self->schemas()} ) {
        $self->_create_dlf_stream( $store, $schema )
          unless $store->has_dlf_stream( $schema );
    }
    return;
}

sub _create_dlf_stream {
    my ( $self, $store, $schema_id ) = @_;

    my $schema = Lire::DlfSchema::load_schema( $schema_id );
    my $analysers = Lire::PluginManager->analysers_by_dst( $schema_id );
    unless ( @$analysers ){
        warn( "no analysers available to create '", $schema_id, "' stream" );
        return;
    }

    my $analyser = $analysers->[0]->name();
    my $cfg = Lire::Config->config_spec()->has_component( "${analyser}_properties") && Lire::Config->get( "${analyser}_properties" ) || '';

    my $process = new Lire::DlfAnalyserProcess( $store, $analyser, $cfg );
    $process->run_analysis_job();

    return;
}

=pod

=head2 generate_report( $store )

Generates a Lire::Report from this report configuration. The report is
computed using the streams in the Lire::DlfStore $store.

=cut

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

    check_object_param( $store, 'store', 'Lire::DlfStore' );

    # Merge the sections' filter specifications
    $self->merge_filters();
    my ( $start, $end ) = $self->_find_dlf_time( $store );

    foreach my $section ( @{$self->{'_sections'}} ) {
        foreach my $report_spec ( $section->reports() ) {
            my $r = $report_spec->subreport_id();
            unless ( $store->has_dlf_stream( $report_spec->schema()->id()) )
            {
                warn( "report '$r' will be skipped because of unavailable input");
                $report_spec->mark_missing( "unavailable input" );
                next;
            }
            eval {
                $report_spec->set_store( $store );
            };
            if ( $@ ) {
                warn( $@ );
                $report_spec->mark_missing( 'set_store() failed: $@' );
            }
        }
    }

    return $self->create_report( $start, $end );
}

sub _find_dlf_time {
    my ( $self, $store ) = @_;

    my $dlf_stream =
      $store->open_dlf_stream( $self->{'_sections'}[0]->superservice(), "r" );

    my $start = $dlf_stream->start_time();
    my $end = $dlf_stream->end_time();

    $dlf_stream->close();

    return ( $start, $end );
}

# Merging

=pod

=head2 merge_report_files( @report_files )

Generate a new Lire::Report based on this report configuration by
merging XML reports. Every report spec contained in the configuration
will be the result of the merging of all the subreports having the
same id.

=cut

sub merge_report_files {
    my ( $self, @files ) = @_;

    $self->_init_merge();

    my $non_missing = {};
    my $parser = new Lire::ReportParser::ReportBuilder();
    foreach my $r ( @files ) {
        my $report = eval { $parser->parsefile( $r ) };
        if ( $@ ) {
            warn( "error parsing XML report $r: $@. Skipping" );
            next;
        }
        $self->_update_merged_timespan( $report );

        $self->_merge_report( $report, $non_missing );
        $report->delete();
    }

    $self->_end_merge( $non_missing );

    return $self->create_report( $self->{'report_start'}, $self->{'report_end'} );
}

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

    foreach my $section ( $self->sections() ) {
        foreach my $spec ( $section->reports() ) {
            my $id = $spec->subreport_id();

            eval { $spec->calc_spec()->init_merge() };
            if ( $@ ) {
                warn( "$@\nreport '$id' will be skipped" );
                $spec->mark_missing( "init_merge() failed: $@" );
            }
        }
    }
}

sub _end_merge {
    my ( $self, $non_missing ) = @_;

    foreach my $section ( $self->sections() ) {
        foreach my $spec ( $section->reports() ) {
            my $id = $spec->subreport_id();

            eval { $spec->calc_spec()->end_merge() };
            if ( $@ ) {
                warn( "$@\nreport '$id' will be skipped" );
                $spec->mark_missing( "end_merge() failed: $@" );
            }

            # Mark missing, if it was also missing in all reports
            $spec->mark_missing( "missing in all merged reports" )
              unless $non_missing->{$id};
        }
    }
}

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

    foreach my $section ( $self->sections() ) {
        foreach my $spec ( $section->reports() ) {
            # Skip failed reports
            next if $spec->is_missing();

            my $id = $spec->subreport_id();
            die "assertion failed: missing subreport_id on specification ",
              $spec->id() unless defined $id;

            # Find the matching subreport in this report
            my $subreport = $report->subreport_by_id( $id );
            unless (  $subreport ) {
                warn( "no subreport id '$id' in this report" );
                next;
            }

            eval { $spec->calc_spec()->merge_subreport( $subreport ); };
            if ($@) {
                warn( $@ );
                warn( "Merge of '$id' failed" );
                next;
            }

            $non_missing->{$id} = 1;
        }
    }
}

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

    # Start and end of merged report is the union of the range of
    # all the reports
    # timespan_start and timespan_end are in seconds since epoch
    unless ( defined $self->{'report_start'} ) {
        $self->{'report_start'} = $report->timespan_start();
        $self->{'report_end'}   = $report->timespan_end();
    }

    # It is possible for a report to have
    # an unknown period
    if ( $report->timespan_start() ) {
        $self->{'report_start'} = $report->timespan_start()
          if $report->timespan_start() < $self->{'report_start'};
        $self->{'report_end'}   = $report->timespan_end()
          if $report->timespan_end() > $self->{'report_end'};
    }
}

# keep perl happy
1;

__END__

=pod

=head1 SEE ALSO

Lire::ReportSection(3pm), Lire::ReportSpec(3pm),
Lire::FilterSpec(3pm) Lire::Report(3pm)

=head1 AUTHOR

  Francis J. Lacoste <flacoste@logreport.org>

=head1 VERSION

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

=head1 COPYRIGHT

Copyright (C) 2002, 2004 Stichting LogReport Foundation LogReport@LogReport.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