source: trunk/soft/ObsData/ObsData.pm @ 220

# $Id$

package ObsData;

use strict;
use warnings;
use Config::IniFiles;
use POSIX qw(strftime);
use ObsData::Repository;
use Mail::Sendmail;
use MIME::QuotedPrint;
use File::Basename;

my @loglevel = (
    'DEBUG',
    'INFO',
    'RESULT',
    'WARNING',
    'ERROR',
    'FATAL',
);

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

=head1 NAME

ObsData - Main object to manage data files

=head1 SYNOPSIS

    use ObsData;
    my $conf = "configfile";
    my $obsdata = ObsData->new($conf);

=head1 METHODS

=head2 new($configfile)

Create a new Obsdata object from $configfile

=cut

sub new {
    my ($class, $configfile, %options) = @_;
    my $obsdata = {
        config => new Config::IniFiles(
            -file => $configfile,
            -default => 'global',
            -allowcontinue => 1
        ),
        verbose => defined($options{verbose}) ? $options{verbose} : 1,
        logcallback => $options{logcallback},
        logfile => $options{logfile},
        dry_run => $options{dry_run},
        interactive_callback => $options{interactive_callback},
        processed_lists => [],
    };

    if (!($configfile && -f $configfile && -r _)) {
        return undef;
    }

    $obsdata->{config} or return undef;

    # directory where to search plugins
    @{$obsdata->{plugindir}} = grep { $_ && -d $_ } (
        $options{plugindir},
        dirname($0),
        $obsdata->{config}->val('.', 'plugindir'),
    );
        
    $obsdata->{logfile} ||= $obsdata->{config}->val('.', 'logfile') || 'obsdata.log';

    bless($obsdata, $class);
}

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

    if ($self->{loghandle}) {
        close($self->{loghandle});
        $self->{loghandle} = undef;
    }
}

=head2 load

Prepare the object for usage

=cut

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

    if (!open($self->{loghandle}, ">> $self->{logfile}")) {
        $self->{loghandle} = undef;
        $self->logging(5, "Can't open log file %s, exiting", "$self->{logfile}");
        return 0;
    }
    
    $self->load_plugins();
    
    return 1;
}

=head2 load_plugins

Load plugins files and get code reference.

=cut

sub load_plugins {
    my ($self) = @_;
    foreach my $datatype ($self->list_datatype()) {
        foreach my $plugin (qw/match_plugin/) {
            my $plugfile = $self->getvalue($datatype, $plugin)
                or next; # if no plugin, skipping
            my ($plugfilename) = grep { -f $_ }
                map { "$_/$plugfile" } @{$self->{plugindir}};
            if (!$plugfilename) {
                $self->logging(5,
                    "Cannot find plugin %s (%s) for %s datatype",
                    $plugfile,
                    $plugin,
                    $datatype,
                );
                next; # FIXME die ??
            }
            my $sub = do $plugfilename;
            if ($sub && ref $sub eq 'CODE') {
                $self->{plugin}{$datatype}{$plugin} = $sub;
                $self->logging(0,
                    "loading plugin %s for %s (%s)",
                    $plugin,
                    $datatype,
                    $sub,
                );
            } else {
                $self->logging(4,
                    "Cannot load plugin %s for %s (is %s)",
                    $plugin,
                    $datatype,
                    $sub ? ref $sub : 'undef or empty',
                );
            }
        }
    }
}

=head2 get_sub_plugin

Return code ref of plugintype for datatype

=cut

sub get_sub_plugin {
    my ($self, $datatype, $plugintype) = @_;
    if (exists($self->{plugin}{$datatype}{$plugintype})) {
        return $self->{plugin}{$datatype}{$plugintype};
    } else {
        return undef;
    }
}

=head2 logging($level, $message, ...)

Pass a message into the logging process.

   $level is the level of message
   $message and or other arguments are printf format string 

=cut

sub logging {
    my ($self, $level, $fmt, @val) = @_;
    my $msg = sprintf($fmt, @val);
    my $logh = $self->{loghandle};
    if ($self->{logcallback}) {
        $self->{logcallback}->($level, $msg);
    }
    if($level >= 0 && $level >= $self->{verbose}) {
        if ($logh) {
            printf $logh 
                "%-9s %s %s\n", 
                sprintf("[%s]", $self->loglevel($level)),
                strftime("%b %d %H:%M:%S %Y", gmtime),
                $msg;
        }
    }
    $msg
}

=head2 loglevel($level)

Return the text human readable log level associate to $level number

=cut

sub loglevel {
    my $l = pop(@_);
    defined($l) or $l = pop(@_);
    return $loglevel[ $l ] || "?????";
}

=head2 checkconfig()

Check the validity of information contains in configfile.

Notice: This test does not include the syntaxe validity

=cut

sub checkconfig {
    my ($self) = @_;
    my $result = 1;
    foreach my $g ($self->{config}->GroupMembers('Obs')) {
        my ($obs) = $g =~ /\S+\s+(.*)/;
        if (!$self->{config}->SectionExists($obs)) {
            print STDERR "E: '$obs' is listed as Obs but it does not exists\n";
            next;
        }
        foreach my $param ($self->{config}->Parameters($obs)) {
        }
        foreach my $datatype ($self->list_datatype) {
            foreach my $var (qw(match match_archive)) {
                my $regexp = $self->getvalue($datatype, $var) or next; # next ? are we sure ?
                eval { qr/$regexp/ }; # Many thanks Rafael
                if ($@) {
                    $self->logging(4, "error in regexp for %s: '%s': %s",
                        $datatype,
                        $regexp,
                        $@,
                    );
                    $result = 0;
                    # TODO set this reg unavalable
                }
            }
        }
    }
    return($result);
}

=head2 getvalue($section, $var, $default)

Return a value from the configuration, $default is assumed if the value is not set

=cut

sub getvalue {
    my ($self, $section, $var, $default) = @_;
    $self->{config}->val($section, $var, $default);
}

=head2 config_mtime

Return the modification time of config file currently used

=cut

sub config_mtime {
    my ($self) = @_;
    return $self->{configmtime} ||= (stat($self->{config}->GetFileName))[9];
}

=head2 list_obs

Return the list of observatories defined in configuration

=cut

sub list_obs {
    my ($self) = @_;
    grep { $self->{config}->SectionExists($_) }
        map { s/^\S+\s+//; $_ }
        $self->{config}->GroupMembers('Obs');
}

=head2 is_obs($obsname)

Return True if $obsname is an observatory

=cut

sub is_obs {
    my ($self, $obs) = @_;
    scalar(grep { $_ eq "Obs $obs" } $self->{config}->GroupMembers('Obs'));
}

=head2 list_obsdatadir($obsname)

Return a hash of data directories per data type for $obsname observatories

=cut

sub list_obsdatadir {
    my ($self, $obs) = @_;
    $self->is_obs($obs) or return undef;
    map { m,^datadir/(.*),; ( ($1 || "") => $self->{config}->val($obs, $_) ) }
        grep { m,^datadir/, || $_ eq 'datadir' }
        $self->{config}->Parameters($obs)
}

=head2 list_typedatadir($type)

List all directories for $type data

=cut

sub list_typedatadir {
    my ($self, $type) = @_;
    my %dirs;
    foreach my $obs ($self->list_obs) {
        $dirs{$_} = 1 foreach(grep { $_ } $self->get_datadir($obs, $type));
    }
    keys %dirs; 
        
}

=head2 get_datadir($obs, $type)

Return a list of directories for $type data on $obs observatory

=cut

sub get_datadir {
    my ($self, $obs, $type) = @_;
    $self->is_obs($obs) or return undef;
    grep { defined($_) } ($self->getvalue($obs, "datadir/$type"), $self->getvalue($obs, "datadir"));
}

=head2 list_datatype

Return a list of datatype handle by config

=cut

sub list_datatype {
    my ($self) = @_;
    grep { $_ ne 'global' }
    grep { $_ !~ /^Obs\s+/ }
    grep { !$self->is_obs($_) } $self->{config}->Sections;
}

=head2 get_obs_data_handle($obs, $datatype)

Return an ObsData::Repository object about directory for $obs station
about $datatype data. $datatype can be undefined if you want to get default
directory

=cut

sub get_obs_data_handle {
    my ($self, $obs, $datatype) = @_;

    my $dir = $self->getvalue($obs, ($datatype ? "datadir/$datatype" : "datadir"));
    if (!$dir) {
        $self->logging(4,
            "Can't find data directory for %s, type: %s",
            $obs, $datatype || '(none)'
        );
        return undef;
    }
    my $or = ObsData::Repository::dir->new(
        {
            obsdata => $self,
            dir => $dir,
            obs => $obs,
            datatype => $datatype,
            dry_run => $self->{dry_run}, # FIXME does this have a better place ?
            patern => $self->getvalue(
                $obs,
                ($datatype ? "searchfiles/$datatype" : "searchfiles")
            ),
            statusfile => $self->getvalue(
                $obs, 
                ($datatype ? "index/$datatype" : "index"),
                "$dir/obsdata.ini"
            ),
        }
    );
    if (!defined($or)) {
        $self->logging(4, "Can't parse %s, check directory exists", $dir);
        return undef;
    }
    
    return($or);
}

=head2 process_obs($obs)

Process all data handle by $obs station

=cut

sub process_obs {
    my ($self, $obs) = @_;
    my %datadir = $self->list_obsdatadir($obs);
    $self->logging(0, "Starting %s() for %s", (caller(0))[3], $obs);
    
    foreach my $datatype (keys %datadir) {
        my $or = $self->get_obs_data_handle($obs, $datatype);
        $or or next;
        $or->process;
    }
}

sub processed {
    my ($self, $obs, $archive, $datafile, $datatype, $dest) = @_;
    push(@{$self->{processed_lists}},
        {
            obs => $obs,
            archive => $archive,
            datafile => $datafile,
            datatype => $datatype,
            destfile => $dest,
        }
    );
    $self->logging(
        2, "Extraction of %s/%s done as %s",
        $archive,
        $datafile,
        $dest,
    );
}

sub generated_reported {
    my ($self) = @_;
    my $result = {
        all => [],
        users => {},
    };

    foreach my $entry (@{$self->{processed_lists}}) {
        my @people = split(/\s*,\s*/, $self->getvalue($entry->{datatype}, 'reportto') || "");
        @people or next;
        foreach my $p (@people) {
            push(@{$result->{users}{$p}{$entry->{datatype}}}, $entry);
        }
    }

    foreach my $p (keys(%{$result->{users} || {}})) {
        my %msg = (
            Subject => 'ObsData Report',
            To => $p,
            'X-ObsData-Version' => $VERSION,
            'Content-Type' => "TEXT/PLAIN;\n  charset=ISO-8859-1",
            'Content-Transfer-Encoding' => 'QUOTED-PRINTABLE',
            From => 'ObsData <robot@aerov.jussieu.fr>',
        );
        my $message = "";
        foreach my $d (keys(%{$result->{users}{$p} || {}})) {
            $message .= "\nDataType: $d\n";
            foreach (@{$result->{users}{$p}{$d} || []}) {
                $message .= sprintf("\tfile %s from %s\n\t=> %s\n",
                    $_->{datafile},
                    $_->{archive},
                    $_->{destfile},
                );
            }
        }
        sendmail(
            %msg,
            smtp => 'mailhost',
            Message => encode_qp($message),
        ) or $self->log(4, "Cannot send mail to %s: %s",
            $msg{To}, $Mail::Sendmail::error,
        );
    }
    return $result;
}

sub postprocessed {
    my ($self) = @_;
    my %datastype;
    foreach my $entry (@{$self->{processed_lists}}) {
        push(@{$datastype{$entry->{datatype}}}, $entry);
    }

    foreach my $datatype (keys %datastype) {
        my $command = $self->getvalue($datatype, 'postexec');
        $self->logging(0, 'postexec for %s is %s',
            $datatype,
            $command ? "`$command'" : 'not set, skipping',
        );
        if ($command) {
            if (open(my $posthandle, "| $command")) {
                foreach (@{$datastype{$datatype}}) {
                    print $posthandle "$_->{destfile}\n" or do {
                        $self->logging(4, "cannot write to postexec handle for `%s': %s",
                            $datatype,
                            $!,
                        );
                        last;
                    };
                }
                my $exitstatus = close($posthandle);
                $self->logging($exitstatus ? 0 : 4,
                    "postexec for %s exit %s",
                    $datatype,
                    $exitstatus ? "correctly" : "with failure : " . ($! ? ($!) : "(??)"),
                );
            } else {
                $self->logging(4, "Cannot exec post `%s' for `%s'",
                    $command,
                    $datatype,
                );
                next;
            }
        }
    }
}

1;

=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