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

package Lire::OldDlfAdapter;

use strict;

use base qw/ Lire::DlfConverter /;

use Carp;

use Fcntl;
use File::Basename qw/ basename /;
use Symbol;

use Lire::DlfSchema;
use Lire::Utils qw/ tempdir check_param /;
use Lire::DataTypes qw/ check_superservice /;
use File::Path qw/rmtree/;

=pod

=head1 NAME

Lire::OldDlfAdapter - Module which bridges with old-style DLF converters

=head1 SYNOPSIS

  my $converter = new Lire::OldDlfAdatper( "www",
                                           "/usr/libexec/lire/converters/combined2dlf" );

=head1 DESCRIPTION

This class can be used to integrate the script-based old-style DLF
converters to the new API.

=head2 new( $schema, $script )

The constructor takes the schema's supported by the script and the
path to the script which implements the DLF converter.

=cut

sub new {
    my ( $class, $schema, $script ) = @_;

    check_param( $schema, 'schema',
                 sub { Lire::DlfSchema->has_schema( $_[0] ); },
                 'invalid schema name' );
    check_param( $script, 'script', sub { -x $_[0] },
                 'script is not executable' );

    my ($name) = basename( $script );
    croak "invalid script name: $script (should be <service>2dlf)"
      unless $name =~ /^(\w+)2dlf$/;

    my $self = bless { '_name'   => $1,
                       '_script' => $script,
                       '_schema' => $schema,
                     }, ref $class || $class;
    return $self;
}

#------------------------------------------------------------------------
# Method name()
#
# Required by Lire::DlfConverter.
sub name {
    $_[0]{'_name'};
}

=pod

=head2 script()

Returns the path to the script which is used to create the DLF records

=cut

sub script {
    $_[0]{'_script'};
}

#------------------------------------------------------------------------
# Method title()
#
# Required by Lire::DlfConverter.
sub title {
    "$_[0]{'_name'} log file";
}

#------------------------------------------------------------------------
# Method description()
#
# Required by Lire::DlfConverter.
sub description {
    "<para>Adapter for old-style DLF converter $_[0]{'_script'}.</para>";
}

#------------------------------------------------------------------------
# Method schemas()
#
# Required by Lire::DlfConverter.
sub schemas {
    ( $_[0]{'_schema'} );
}


#------------------------------------------------------------------------
# Method handle_log_lines()
#
# Required by Lire::DlfConverter.
sub handle_log_lines { 1 }

#------------------------------------------------------------------------
# Method init_dlf_converter( $process )
#
# Required by Lire::DlfConverter.
sub init_dlf_converter {
    my ( $self, $process ) = @_;

    my $schema = Lire::DlfSchema::load_schema( $self->{'_schema'} );
    $self->{'_field_names'} = [];
    foreach my $f ( $schema->fields ) {
        push @{$self->{'_field_names'}}, $f->name;
    }

    $self->{'_dlffile'} = undef;
    $self->{'_logfile'} = undef;
    $self->{'_tmpdir'} = tempdir( $self->{'_name'} . "_XXXXXX" );
    open( $self->{'_dlffile'}, "+> $self->{'_tmpdir'}/$self->{'_name'}.dlf" )
      or die "can't open temporary dlf file: $!\n";
    open( $self->{'_logfile'}, "+> $self->{'_tmpdir'}/$self->{'_name'}.log" )
      or die "can't open temporary log file: $!\n";

    my ($read_fh, $write_fh) = ( gensym, gensym );
    pipe( $read_fh, $write_fh )
      or die "pipe failed: $!\n";
    $self->{'_convert_pid'} = fork;
    die "fork failed: $!\n" unless defined $self->{'_convert_pid'};
    if ( !$self->{'_convert_pid'} ) {
        close $write_fh;
        open( STDIN, "<&". fileno( $read_fh ) )
          or die "cannot redirect STDIN to pipe: $!\n";
        close $read_fh;
        open( STDOUT, ">&" . fileno( $self->{'_dlffile'} ) )
          or die "cannot redirect STDOUT to file: $!\n";
        close $self->{'_dlffile'};
        open( STDERR, ">&" . fileno( $self->{'_logfile'} ) )
          or die "cannot redirect STDERR to file:\n";
        close $self->{'_logfile'};
        exec( $self->{'_script'} )
          or die "exec $self->{'_script'} failed: $!\n";
    }
    close $read_fh;

    $self->{'_convert_fh'} = $write_fh;
}

#------------------------------------------------------------------------
# Method process_log_line( $process, $line )
#
# Required by Lire::DlfConverter.
sub process_log_line {
    my ( $self, $process, $line ) = @_;

    print {$self->{'_convert_fh'}} $line, "\n"
      or die "error while sending data to old dlf converter: $!\n";

    return;
}

#------------------------------------------------------------------------
# Method finish_conversion( $process )
#
# Required by Lire::DlfConverter.
sub finish_conversion {
    my ( $self, $process ) = @_;

    close $self->{'_convert_fh'}
      or die "closing pipe failed: $!\n";
    waitpid $self->{'_convert_pid'}, 0
      or die "waitpid failed: $!\n";
    my $status = $?;

    $self->_import_dlf( $process );
    $self->_import_errors( $process );

    die "old-style DLF converter exited with non-zero status: $?\n"
      if $status;

    rmtree( $self->{'_tmpdir'} );

    return;
}

sub _import_dlf {
    my ($self, $process)  = @_;

    my $fh = $self->{'_dlffile'};
    seek $fh, 0, 0
      or die "can't rewind temporary DLF file: $!\n";

    my $field_count = @{$self->{'_field_names'}};
    my $line;
    while ( defined( $line = <$fh>) ) {
        chomp $line;
        my %r = ();
        my $i=0;
        foreach my $v ( split / /, $line ) {
            $r{$self->{'_field_names'}[$i++]} =
              $v eq 'LIRE_NOTAVAIL' ? undef : $v;
        }
        if ($i != $field_count ) {
            $process->error( "only $i fields when $field_count expected",
                             $line );
        } else {
            $process->write_dlf( $self->{'_schema'}, \%r );
        }
    }
}

sub _import_errors {
    my ( $self,$process ) = @_;

    my $fh = $self->{'_logfile'};
    seek $fh, 0, 0
      or die "can't rewind temporary log file: $!\n";
    my $line;
    while (defined ( $line = <$fh> ) ) {
        chomp $line;
        my ($super,$service,$id,$prog,$level, $msg ) = split /\s+/, $line, 6;
        next unless $level =~ /^(crit|err|warning)$/;
        $process->error( $msg );
    }
}

# keep perl happy
1;

__END__

=pod

=head1 SEE ALSO

Lire::DlfConverterProcess(3pm), Lire::DlfStore(3pm), Lire::ImportJob(3pm),
Lire::PluginManager(3pm), Lire::DlfConverter(3pm)

=head1 AUTHOR

  Francis J. Lacoste <flacoste@logreport.org>

=head1 VERSION

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

=head1 COPYRIGHT

Copyright (C) 2002 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