source: obsdata/tags/0.3.3/ObsData/Repository.pm @ 339

# $Id$

package ObsData::Repository;

use strict;
use warnings;
use File::Path;
use POSIX qw(getcwd);
use ObsData;
use ObsData::Archive;
use ObsData::Event;
use ObsData::Repository::Status;
use POSIX qw(strftime);

our $CVSID = q$Id$;
our $CVSREV = ( q$Revision$ =~ /^Revision: (.*) $/ )[0];

=head1 METHODS

=head2 ObsData::Repository

=head3 new($parent, %param)

Create a new ObsData::Repository object

=over 4

=item $parent

A ObsData::Repository to take information

=item %param

A list of paramter to set in new object:

=over 4

=item datatype 

If set, only this datatype will be checked

=item obs

The obsveratory where data come from, informationnal only

=item dir

The based directory where archive are located

=item glob

Apply this glob to search files in dir

=item statusfile

The file where status info should be written

=item status

The Config::IniFiles object

=back

=back

=cut

sub new {
    my ( $class, $parent, %param ) = @_;

    my $or = {%$parent};
    foreach ( keys %param ) {
        $or->{$_} = $param{$_};
    }

    $or->{obsdata} or die "Error #1de8d015, please insult programmer";
    $or->{dir}     or die "No dir given";
    -d $or->{dir}  or return undef;

    $or->{status} ||= new ObsData::Repository::Status(
        filename => $or->{statusfile},
    );
    $or->{statusfile}           ||= $or->{status}->GetFileName;
    $or->{interactive_callback} ||= $or->{obsdata}->{interactive_callback};

    bless( $or, $class );

    $or;
}

sub DESTROY {
    my ($self) = @_;
    $self->logging( 0, "Destroy ObsData::Repository for %s", ref($self) );
    $self->save_status;
}

=head3 mydir

return directory handle by the object

=cut

sub mydir {
    $_[0]->{dir};
}

=head3 update_global_status

Set standard information into status ini file

=cut

sub update_global_status {
    my ($self) = @_;
    $self->{status}->AddSection('.');
    $self->{status}
      ->SetSectionComment( '.', $ObsData::CVSID, $ObsData::Repository::CVSID,
        scalar(localtime), );

    my $hostname = `hostname`;
    chomp($hostname);
    $self->{status}->newval( '.', 'hostname', $hostname );
    $self->{status}
      ->SetParameterComment( '.', 'hostname', 'The computer host name' );

    $self->{status}->newval( '.', 'directory', $self->{dir} );
    $self->{status}->SetParameterComment( '.', 'directory',
        'Directory where archive where located' );

    $self->{status}->newval( '.', 'runfrom', getcwd() );
    $self->{status}
      ->SetParameterComment( '.', 'runfrom', 'The current directory' );
}

=head3 save_status

Save current information about parsed files into status file

=cut

sub save_status {
    my ($self) = @_;
    $self->{statusfile} or return;
    if ( !$self->{dry_run} ) {
        $self->logging( 0, "Writing status file: %s", $self->{statusfile}, );
        $self->update_global_status;
        $self->{status}->WriteConfig( $self->{statusfile} );
    }
}

=head3 dump_status($output)

Dump current status file into $output, see Config::IniFiles,
function WriteConfig

=cut

sub dump_status {
    my ( $self, $output ) = @_;
    $self->update_global_status;
    $self->{status}->WriteConfig($output);
}

=head3 logging($level, $msg, ...)

Pass a message for logging to ObsData Object. See L<ObsData>

=cut

sub logging {
    my $self = shift;
    $self->{obsdata}->logging(@_);
}

=head2 ObsData::Repository::dir

The child class to handle directory

=cut

package ObsData::Repository::dir;

our @ISA = qw(ObsData::Repository);

=head3 new

=cut

sub new {
    my ( $class, $infos, %param ) = @_;

    my $or = ObsData::Repository->new( $infos, %param ) or return;

    bless( $or, $class );
}

=head3 findfile

Return the list of files needing to be checked

=cut

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

    if ( !-d $self->{dir} ) {
        $self->logging( 3, "directory %s does not exists", $self->{dir}, );
        return;
    }

    my $patern = $self->{patern} || '*';
    foreach my $f ( glob("$self->{dir}/$patern") ) {

        -f $f or next;    # skip no regular files
        $f =~ m/obsdata\.ini$/ and next;    # avoid default status file

        my $bf = $f;
        $bf =~ s!^\Q$self->{dir}\E/*!!;
        push( @files, $bf );
    }
    @files;
}

=head3 list_archive_from_status()

Return the list of archive currently registered in status file.

=cut

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

    grep { $_ ne '.' } $self->{status}->Sections;
}

=head3 process

Process all files in directory

=cut

sub process {
    my ($self) = @_;
    $self->logging( 0, "%s() start for %s", ( caller(0) )[3], $self->{dir} );

    foreach my $file ( $self->findfile ) {
        my $orda =
          ObsData::Repository::dir::archive->new( $self, archivefile => $file,
          );

        my $oe = ObsData::Event->new( 'do_archive', "Should I parse $file" );

        $oe->add_test( 'archive_exists',
            $self->{status}->SectionExists( $orda->{archivefile} )
            ? ( "Archive file found in index", 1 )
            : ( "Archive file not found in index", 0 ) );

        if ( defined( my $oldsize = $orda->getvalue('size') ) ) {
            my $size = ( stat("$orda->{dir}/$orda->{archivefile}") )[7];

            $oe->add_test( 'archive_size',
                  ( $size <=> $oldsize ) == 0
                ? ( sprintf( "size does not differ (%d)", $size ), 1 )
                : ( sprintf( "differ %d => %d", $oldsize, $size ), 0 ) );
        }

        if ( defined( my $oldmtime = $orda->getvalue('mtime') ) ) {
            my $mtime = ( stat("$orda->{dir}/$orda->{archivefile}") )[9];
            $oe->add_test( 'archive_mtime',
                  ( $mtime <=> $oldmtime ) == 0
                ? ( sprintf( "mtime does not differ (%d)", $mtime ), 1 )
                : ( sprintf( "differ %d => %d", $oldmtime, $mtime ), 0 ) );
        }

        $orda->ask_user($oe) or next;

        $orda->process;
    }
}

sub get_archives_from_status {
    my ($self) = @_;
    map { ObsData::Repository::dir::archive->new( $self, archivefile => $_, ) }
      $self->list_archive_from_status();
}

=head2 ObsData::Repository::dir::archive

Object to handle archive and to dispatch data

=cut

package ObsData::Repository::dir::archive;

use POSIX qw(strftime);

our @ISA = qw(ObsData::Repository);

=head3 new($info, %param)

Return a new ObsData::Repository::dir::archive object.

$info is an ObsData::Repository or ObsData::Repository::dir object

%param are:
    
    archivefile => the archive file to read

=cut

sub new {
    my ( $class, $infos, %param ) = @_;

    my $or = ObsData::Repository->new( $infos, %param ) or return;

    # dir directory to parse
    $or->{archivefile} or die "No archivefile given";

    # $or->{interactive_callback}
    $or->{_cache_checks} = {};

    $or->logging( 0, "Preparing to parse %s/%s",
        $or->{dir}, $or->{archivefile} );

    bless( $or, $class );
}

sub DESTROY {
    my ($self) = @_;
    $self->logging( 0, "Destroy ObsData::Repository for %s", ref($self) );
#    if ( $self->{status_changed} ) {
#        $self->save_status;
#    }
}

=head3 archivefile

Return the archive name handle by this object

=cut

sub archivefile {
    $_[0]->{archivefile};
}

=head3 load_archive

Try to read archive, return 1 on success

=cut

sub load_archive {
    my ($self) = @_;
    if ( $self->{Oarchive} ) {
        return 1;
    }
    else {
        $self->{Oarchive} =
          ObsData::Archive->new("$self->{dir}/$self->{archivefile}");
        if ( $self->{Oarchive} ) {
            $self->logging( 0, "Archive %s/%s properly load",
                $self->{dir}, $self->{archivefile} );
            return 1;
        }
        else {
            $self->logging( 4, "Can't handle archive %s/%s: %s, skipping",
                $self->{dir}, $self->{archivefile}, ObsData::Archive->error );
            return 0;
        }
    }
}

=head2 archive()

Return the ObsData::Archive object handle by the object, load it if need.
Return undef if failed.

=cut

sub archive {
    my ($self) = @_;
    if ( $self->load_archive() ) {
        return $self->{Oarchive};
    }
    else {
        return undef;
    }
}

=head2 getvalue($var, $default)

Return a value from status file related to current archive.

=cut

sub getvalue {
    my ( $self, $var, $default ) = @_;
    return $self->{status}->val( $self->{archivefile}, $var, $default );
}

=head2 setvalue

Define a value related to current archive file.

=cut

sub setvalue {
    my ( $self, $var, $val, $comment ) = @_;
    if ( !$self->{status}->SectionExists( $self->{archivefile} ) ) {
        $self->{status}->AddSection( $self->{archivefile} );
    }
    $self->{status}->newval( $self->{archivefile}, $var, $val )
      if ( defined($val) );
    $self->{status}->SetParameterComment( $self->{archivefile}, $var, $comment )
      if ( defined($comment) );
    $self->{status_changed} = 1;
}

=head2 get_data_value($datafile, $var, $default)

Return a value from status file related to current archive about $datafile.

=cut

sub get_data_value {
    my ( $self, $datafile, $var, $default ) = @_;
    return $self->getvalue( sprintf( 'data_%s_%s', $var, $datafile ),
        $default );
}

=head2 set_data_value($datafile, $var, $val, $comment)

Set a value and optionnaly a comment for $datafile found in archive file

=cut

sub set_data_value {
    my ( $self, $datafile, $var, $val, $comment ) = @_;
    $self->setvalue( sprintf( 'data_%s_%s', $var, $datafile ), $val, $comment );
}

=head3 checks

=cut

=head3 default_choice($oevent)

In batch mode, check ObsData::event content and return result about behaviour
soft whould have.

=cut

sub default_choice {
    my ( $self, $oevent ) = @_;

    for ( $oevent->id ) {
        /^do_archive$/ and do {
            return ( $oevent->test_result('archive_exists') ? 0 : 1 );
            last;
        };
        /^do_data$/ and do {
            return 1;    # TODO
            last;
        };
        /^overwrite$/ and do {
            return ( $oevent->test_result('dest_exists') ? 0 : 1 );
            last;
        };
    }
}

=head3 ask_user($oevent)

The function take a filled ObsData::Event object, and perform return
default_choice verification or result the callback set by the application.

=cut

sub ask_user {
    my ( $self, $oevent ) = @_;

    $self->logging( 0, "Event(%s): %s", $oevent->id, $oevent->message );
    foreach ( $oevent->list_test ) {
        $self->logging(
            0, "  (%s) %s: %s",
            $_,
            $oevent->test_message($_),
            $oevent->test_result($_),
        );
    }

    my $res =
        $self->{interactive_callback}
      ? $self->{interactive_callback}->( $self, $oevent )
      : $self->default_choice($oevent);

    $self->logging( 0, "Event(%s): Result: %s", $oevent->id, $res );
    return ($res);
}

=head3 list_archive

Return archive content

=cut

sub list_archive {
    my ($self) = @_;
    if ( my $archive = $self->archive ) {
        return $archive->ls();
    }
    else {
        return undef;
    }
}

=head3 update_status

Update status information about current archive

=cut

sub update_status {
    my ($self) = @_;
    my @filestats = stat("$self->{dir}/$self->{archivefile}");

    $self->setvalue( 'mtime',      $filestats[9] );
    $self->setvalue( 'size',       $filestats[7] );
    $self->setvalue( 'configtime', $self->{obsdata}->config_mtime );
}

=head3 find_match_data_type($label)

Check if datafile match one of the regexp associate to datatype in the
configuration, if yes, return the datatype and assiociate values, else
return nothing

=cut

sub match_data_type {
    my ( $self, $datafile ) = @_;
    foreach
      my $datatype ( ( $self->{datatype} ) || $self->{obsdata}->list_datatype )
    {
        my $regexp = $self->{obsdata}->getvalue( $datatype, 'match' ) or next;
        my @data = $datafile =~ /$regexp/i;
        my @dataar = $self->archive_match($datatype);
        my ( $pret, %parg ) =
          $self->get_info_from_plugin( $datatype, $datafile );

        # if no regexp => return undef
        # if regexp and match, @dataar contain something
        # if regexp no match, @dataar is empty
        if (   @data
            && ( @dataar             || !defined( $dataar[0] ) )
            && ( ( !defined($pret) ) || $pret ) )
        {
            return ( $datatype, \@data, \@dataar, \%parg );
        }
    }
    return;
}

=head3 archive_match($datatype)

Apply matching to archive filename

=cut

sub archive_match {
    my ( $self, $datatype ) = @_;
    my $regexp = $self->{obsdata}->getvalue( $datatype, 'match_archive' )
      or return undef;
    my @data = $self->{archivefile} =~ /$regexp/i;
    return @data;
}

=head3 get_info_from_plugin($datatype, $datafile)

First arg is:
  undef if no plugin
  0 no match
  1 match, %list follow

=cut

sub get_info_from_plugin {
    my ( $self, $datatype, $datafile ) = @_;

    my %val;

    my ( $sub, @args ) =
      $self->{obsdata}->get_sub_plugin( $datatype, 'match_plugin' );
    if ($sub) {
        $self->logging( 0, "Found plugin %s for %s, running it",
            'match_plugin', $datatype, );

        return $self->run_plugin( $sub, $datatype, $datafile, @args );
    }
    else {
        return undef;
    }
}

=head3 run_plugin( $sub, $datatype, $datafile, @args )

Run the plugin code for a datafile

    $sub is the code ref
    $datatype is type of data expect if any
    $datafile is the filename in archive
    @arg arbitrary information

=cut

sub run_plugin {
    my ( $self, $sub, $datatype, $datafile, @args ) = @_;
    my ( $exitstatus, @result ) =
      $sub->( $self, 'match_plugin', $datafile, $datatype || "-", @args, );
    if ($exitstatus) {
        if ( @result % 2 == 0 ) {
            $self->logging( 0, "Plugin %s for %s exit with %s (%d values)",
                'match_plugin', $datatype, $exitstatus, scalar(@result), );
            return ( 1, @result );
        }
        else {
            $self->logging( 4, "Plugin %s for %s return impair values %d",
                $datatype, $exitstatus, scalar(@result), );
            return undef;
        }
    }
    else {
        $self->logging( 0, "Plugin %s of %s exit with null, skipping",
            'match_plugin', $datatype, );
        return 0;
    }
}

=head3 build_dest_filename($datafile)

Build the destination file from original filename and optionnaly.
Return the datatype and the filename. If no datatype apply,
return undef, if destination file cannot be build, return only the datatype.

If object datatype is not defined, the function try to find the right datatype from
configuration.

=cut

sub build_dest_filename {
    my ( $self, $datafile ) = @_;
    my ( $datatype, $data, $dataar, $parg ) = $self->match_data_type($datafile);

    if ( !$datatype ) {
        return;
    }

    my %val = %{ $parg || {} };

    my $dest = $self->{obsdata}->getvalue( $datatype, 'dest' );
    my @matcharg =
      split( /\s+/, $self->{obsdata}->getvalue( $datatype, 'matcharg' ) || '' );
    my @matcharg_ar =
      split( /\s+/,
        $self->{obsdata}->getvalue( $datatype, 'matcharg_archive' ) || '' );
    my @destarg =
      split( /\s+/, $self->{obsdata}->getvalue( $datatype, 'destarg' ) || '' );
    my @gmtime = gmtime;

    foreach (@matcharg) {
        $val{$_} = shift(@$data);
    }
    foreach (@matcharg_ar) {
        $val{$_} = shift(@$dataar);
    }

    # FIXME Is this need ?
    # foreach (keys %{$magic_words || {}}) {
    #    $val{'$' . $_} = $magic_words->{$_};
    #}

    $val{'$datafile'}    = $datafile;
    $val{'$archivefile'} = $self->{archivefile};
    ( $val{'$basedatafile'} ) = $datafile =~ m:([^/]*)$:;
    my $destfile = sprintf( $dest,
        map { m/^%/ ? strftime( $_, @gmtime ) : $val{$_} || '' }
          grep { defined($_) } @destarg,
    );
    if ( !$destfile ) {
        $self->logging(
            4,
            "Can evaluate destination file from %s, %s",
            $dest,
            join( ", ",
                map { m/^%/ ? strftime( $_, @gmtime ) : $val{$_} } @destarg )
        );
        return ();
    }
    return ( $datatype, $destfile );
}

# Sub data function:

=head3 get_data_dest($datafile)

Return the datatype and destination for $datafile

=cut

sub get_data_dest {
    my ( $self, $datafile ) = @_;

    my ( $t, $d ) = $self->build_dest_filename( $datafile, $self->{datatype} );
    $self->logging(
        0, "%s/%s file, datatype %s, destination %s",
        $self->{archivefile}, $datafile,
        $t || '(none)',
        $d || '(none)',
    );
    if ($t) {
        $self->set_data_value( $datafile, 'type', $t );
    }
    return ( $t, $d );
}

=head3 extract_data($datafile, $datatype, $destfile)

Extract data file into $destfile, $datafile is informationnal only.

$datatype and $destfile are the result of L<get_data_dest>.

A basic call is:
    $o->extract_data($file, $self->get_data_dest($file));

Return 1 on success

=cut

sub extract_data {

    # $datatype, informationnal only here
    my ( $self, $datafile, $datatype, $destfile ) = @_;
    $self->load_archive or return 0;
    my $ltime = time;

    $self->set_data_value(
        $datafile,
        'processtime',
        $ltime,
        scalar( localtime($ltime) )
          . ", $ObsData::VERSION: $ObsData::CVSREV, $ObsData::Repository::CVSREV",
    );
    $self->set_data_value( $datafile, 'processversion', $ObsData::VERSION, );

    if ( !$destfile ) {
        $self->logging( 3, "%s/%s has no destination",
            $self->{archivefile}, $datafile, );
        $self->{obsdata}
          ->processed( $self->{obs}, $self->{archivefile}, $datafile, );
        return 0;
    }

    my $oe = ObsData::Event->new( 'overwrite', "Should I overwrite $destfile" );

    $oe->add_test( 'dest_exists',
        -e $destfile
        ? ( "$destfile exists", 1 )
        : ( "$destfile don't exists", 0 ) );
    $self->ask_user($oe) or return 0;

    $self->logging( 0, "Trying to extract %s from %s/%s",
        $destfile, $self->{archivefile}, $datafile );

    my ($dirname) = $destfile =~ m!(?:(.*)/)?(.*)$!;    #! vim syntax sux

    if ( $dirname && !-d $dirname ) {
        $self->logging( 1, "Creating directory %s", $dirname );
        if ( $self->{dry_run} ) {
            $self->logging( 1, "Testing mode, assume %s was correctly created",
                $dirname );
        }
        else {
            eval { File::Path::mkpath($dirname) };
            if ($@) {
                $self->logging( 4, "Can't create directory %s: %s",
                    $dirname, $@ );
                return 0;
            }
        }
    }

    if ( $self->{dry_run} ) {
        $self->logging( 2, "Testing mode, %s/%s would be extracted as %s",
            $self->{archivefile}, $datafile, $destfile, );
    }
    else {
        if ( $self->{Oarchive}->extract( $datafile, $destfile ) ) {
            $self->set_data_value( $datafile, 'dest', $destfile );
            $self->{obsdata}
              ->processed( $self->{obs}, $self->{archivefile}, $datafile,
                $datatype, $destfile, );
        }
        else {
            $self->logging(
                4, "Can't extract %s/%s to %s: %s",
                $self->{archivefile}, $datafile, $destfile,
                $self->{Oarchive}->error,
            );
            return 0;
        }
    }

    return 1;
}

=head3 process

Process all files in the archive

=cut

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

    foreach my $data ( $self->list_archive ) {
        $data or next;
        my $oe =
          ObsData::Event->new( 'do_data',
            "Should I extract $data from $self->{archivefile}" );
        $oe->add_test( 'data_extracted',
            $self->get_data_value( $data, 'dest' )
            ? ( 'Data was already extract', 1 )
            : ( 'Data was not already extract', 0 ) );

        $self->ask_user($oe) or next;

        $self->extract_data( $data, $self->get_data_dest($data) );
    }

    $self->update_status;

    return 1;
}

sub list_data_from_status {
    my ($self) = @_;
    map { m/data_processtime_(.*)/; $1 }
      grep { $_ && index( $_, 'data_processtime_' ) == 0 }
      $self->{status}->Parameters( $self->{archivefile} );
}

sub data_extracted {
    my ( $self, $data ) = @_;
    return $self->get_data_value( $data, 'dest' );
}

=head1 LICENSE

This software is under GPL version 2 or highter
(c) 2005, 2006 CNRS Service d'Aeronomie

=head1 AUTHOR

Olivier Thauvin <olivier.thauvin@aerov.jussieu.fr>

=cut

1;