source: trunk/soft/ObsData/ObsData/Repository.pm @ 197

# $Id$

package ObsData::Repository;

use strict;
use warnings;
use File::Path;
use POSIX qw(getcwd);
use ObsData;
use ObsData::Archive;
use ObsData::Event;
use Config::IniFiles;
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 Config::IniFiles(
        -file => (($or->{statusfile} && -f $or->{statusfile}) ? $or->{statusfile} : undef),
        # -default => '.', # Is this a good idea
    );
    $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 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->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;
    }
}

=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);
}

=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 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));
}

=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),
        $var, 
        $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) = @_;
    $self->load_archive or return;
    
    return $self->{Oarchive}->ls;
}

=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/;
        if (@data) {
            return ($datatype, @data);
        }
    }
}

=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 next;
    my @data = $self->{archivefile} =~ /$regexp/;
    return @data;
}

=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) = $self->match_data_type($datafile);
    
    if (! $datatype) {
        return;
    }

    my @ardata = ();
    if (my $arregexp = $self->{obsdata}->getvalue($datatype, 'match_archive')) {
        @ardata = $self->{archivefile} =~ /$arregexp/;
        if (!@ardata) {
            return; # FIXME is this what we want ?
        }
    }

    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;
    my %val;
    foreach (@matcharg) {
        $val{$_} = shift(@data);
    }
    foreach (@matcharg_ar) {
        $val{$_} = shift(@ardata);
    }
    # FIXME Is this need ?
    # foreach (keys %{$magic_words || {}}) {
    #    $val{'$' . $_} = $magic_words->{$_};
    #}
    
    $val{'$datafile'} = $datafile;
    $val{'$archivefile'} = $self->{archivefile};
    my $destfile = sprintf(
        $dest,
        map { m/^%/ ? strftime($_, @gmtime) : $val{$_} } @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,
        );
        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 {
            if( ! File::Path::mkpath($dirname)) { 
                $self->logging(
                    4, "Can't create directory %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->logging(
                2, "Extraction of %s/%s done as %s",
                $self->{archivefile},
                $datafile,
                $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) {
        my $oe = ObsData::Event->new('do_data',
            "Should I extract $data from $self->{archivefile}"
        );
        
        $self->ask_user($oe) or next;

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

    return 1;
}

=head1 AUTHOR

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

=cut

1;