| 1 | # $Id$ |
|---|
| 2 | |
|---|
| 3 | package ObsData; |
|---|
| 4 | |
|---|
| 5 | use strict; |
|---|
| 6 | use warnings; |
|---|
| 7 | use Config::IniFiles; |
|---|
| 8 | use POSIX qw(strftime); |
|---|
| 9 | use ObsData::Repository; |
|---|
| 10 | use Mail::Sendmail; |
|---|
| 11 | use MIME::QuotedPrint; |
|---|
| 12 | use File::Basename; |
|---|
| 13 | |
|---|
| 14 | my @loglevel = ( 'DEBUG', 'INFO', 'RESULT', 'WARNING', 'ERROR', 'FATAL', ); |
|---|
| 15 | |
|---|
| 16 | our $VERSION = "0.3.3"; |
|---|
| 17 | our $CVSID = q$Id$; |
|---|
| 18 | our $CVSREV = ( q$Revision$ =~ /^Revision: (.*) $/ )[0]; |
|---|
| 19 | |
|---|
| 20 | =head1 NAME |
|---|
| 21 | |
|---|
| 22 | ObsData - Main object to manage data files |
|---|
| 23 | |
|---|
| 24 | =head1 SYNOPSIS |
|---|
| 25 | |
|---|
| 26 | use ObsData; |
|---|
| 27 | my $conf = "configfile"; |
|---|
| 28 | my $obsdata = ObsData->new($conf); |
|---|
| 29 | |
|---|
| 30 | =head1 METHODS |
|---|
| 31 | |
|---|
| 32 | =head2 new($configfile) |
|---|
| 33 | |
|---|
| 34 | Create a new Obsdata object from $configfile |
|---|
| 35 | |
|---|
| 36 | =cut |
|---|
| 37 | |
|---|
| 38 | sub new { |
|---|
| 39 | my ( $class, $configfile, %options ) = @_; |
|---|
| 40 | my $obsdata = { |
|---|
| 41 | config => new Config::IniFiles( |
|---|
| 42 | -file => $configfile, |
|---|
| 43 | -default => 'global', |
|---|
| 44 | -allowcontinue => 1 |
|---|
| 45 | ), |
|---|
| 46 | verbose => defined( $options{verbose} ) ? $options{verbose} : 1, |
|---|
| 47 | logcallback => $options{logcallback}, |
|---|
| 48 | logfile => $options{logfile}, |
|---|
| 49 | dry_run => $options{dry_run}, |
|---|
| 50 | interactive_callback => $options{interactive_callback}, |
|---|
| 51 | processed_lists => [], |
|---|
| 52 | }; |
|---|
| 53 | |
|---|
| 54 | if ( !( $configfile && -f $configfile && -r _ ) ) { |
|---|
| 55 | return undef; |
|---|
| 56 | } |
|---|
| 57 | |
|---|
| 58 | $obsdata->{config} or return undef; |
|---|
| 59 | |
|---|
| 60 | # directory where to search plugins |
|---|
| 61 | @{ $obsdata->{plugindir} } = grep { $_ && -d $_ } ( |
|---|
| 62 | $options{plugindir}, |
|---|
| 63 | dirname($0), |
|---|
| 64 | split( /\s+/, $obsdata->{config}->val( 'global', 'plugindir' ) || '' ), |
|---|
| 65 | ); |
|---|
| 66 | |
|---|
| 67 | $obsdata->{logfile} ||= $obsdata->{config}->val( 'global', 'logfile' ) |
|---|
| 68 | || 'obsdata.log'; |
|---|
| 69 | |
|---|
| 70 | bless( $obsdata, $class ); |
|---|
| 71 | } |
|---|
| 72 | |
|---|
| 73 | sub DESTROY { |
|---|
| 74 | my ($self) = @_; |
|---|
| 75 | |
|---|
| 76 | $self->logging( 0, "END process: %s (%s)", $VERSION, $CVSID, ); |
|---|
| 77 | |
|---|
| 78 | if ( $self->{loghandle} ) { |
|---|
| 79 | close( $self->{loghandle} ); |
|---|
| 80 | $self->{loghandle} = undef; |
|---|
| 81 | } |
|---|
| 82 | } |
|---|
| 83 | |
|---|
| 84 | =head2 load |
|---|
| 85 | |
|---|
| 86 | Prepare the object for usage |
|---|
| 87 | |
|---|
| 88 | =cut |
|---|
| 89 | |
|---|
| 90 | sub load { |
|---|
| 91 | my ($self) = @_; |
|---|
| 92 | |
|---|
| 93 | if ( !open( $self->{loghandle}, ">> $self->{logfile}" ) ) { |
|---|
| 94 | $self->{loghandle} = undef; |
|---|
| 95 | $self->logging( 5, "Can't open log file %s, exiting", |
|---|
| 96 | "$self->{logfile}" ); |
|---|
| 97 | return 0; |
|---|
| 98 | } |
|---|
| 99 | |
|---|
| 100 | $self->logging( 0, "BEGIN process: %s (%s)", $VERSION, $CVSID, ); |
|---|
| 101 | |
|---|
| 102 | my $path = `pwd`; |
|---|
| 103 | chomp($path); |
|---|
| 104 | $self->logging( |
|---|
| 105 | 0, |
|---|
| 106 | "Using config file `%s' (%s)", |
|---|
| 107 | $self->{config}->GetFileName(), $path, |
|---|
| 108 | ); |
|---|
| 109 | |
|---|
| 110 | $self->load_plugins() or return 0; |
|---|
| 111 | |
|---|
| 112 | return 1; |
|---|
| 113 | } |
|---|
| 114 | |
|---|
| 115 | =head2 load_plugins |
|---|
| 116 | |
|---|
| 117 | Load plugins files and get code reference. |
|---|
| 118 | |
|---|
| 119 | =cut |
|---|
| 120 | |
|---|
| 121 | sub load_plugins { |
|---|
| 122 | my ($self) = @_; |
|---|
| 123 | |
|---|
| 124 | $self->logging( |
|---|
| 125 | 0, |
|---|
| 126 | "Plugin will be searched in: %s", |
|---|
| 127 | join( ', ', @{ $self->{plugindir} } ), |
|---|
| 128 | ); |
|---|
| 129 | |
|---|
| 130 | foreach my $datatype ( $self->list_datatype() ) { |
|---|
| 131 | foreach my $plugin (qw/match_plugin/) { |
|---|
| 132 | my ( $plugfile, @plugarg ) = |
|---|
| 133 | split( /\s+/, $self->getvalue( $datatype, $plugin ) || '' ); |
|---|
| 134 | $plugfile or next; # if no plugin, skipping |
|---|
| 135 | my ($plugfilename) = grep { -f $_ } |
|---|
| 136 | map { "$_/$plugfile" } @{ $self->{plugindir} }; |
|---|
| 137 | if ( !$plugfilename ) { |
|---|
| 138 | $self->logging( 5, "Cannot find plugin %s (%s) for %s datatype", |
|---|
| 139 | $plugfile, $plugin, $datatype, ); |
|---|
| 140 | return 0; |
|---|
| 141 | } |
|---|
| 142 | my $sub = do $plugfilename; |
|---|
| 143 | if ($@) { |
|---|
| 144 | $self->logging( 4, |
|---|
| 145 | "Cannot load plugin %s for %s: %s, exiting !", |
|---|
| 146 | $plugin, $datatype, $@, ); |
|---|
| 147 | return 0; |
|---|
| 148 | } |
|---|
| 149 | if ( $sub && ref $sub eq 'CODE' ) { |
|---|
| 150 | $self->{plugin}{$datatype}{$plugin} = { |
|---|
| 151 | code => $sub, |
|---|
| 152 | arg => \@plugarg, |
|---|
| 153 | }; |
|---|
| 154 | $self->logging( 0, "loading plugin %s for %s (%s)", |
|---|
| 155 | $plugin, $datatype, $sub, ); |
|---|
| 156 | } |
|---|
| 157 | else { |
|---|
| 158 | $self->logging( |
|---|
| 159 | 4, "Cannot load plugin %s for %s (is %s)", |
|---|
| 160 | $plugin, $datatype, $sub ? ref $sub : 'undef or empty', |
|---|
| 161 | ); |
|---|
| 162 | } |
|---|
| 163 | } |
|---|
| 164 | } |
|---|
| 165 | return 1; |
|---|
| 166 | } |
|---|
| 167 | |
|---|
| 168 | =head2 get_sub_plugin |
|---|
| 169 | |
|---|
| 170 | Return code ref of plugintype for datatype |
|---|
| 171 | |
|---|
| 172 | =cut |
|---|
| 173 | |
|---|
| 174 | sub get_sub_plugin { |
|---|
| 175 | my ( $self, $datatype, $plugintype ) = @_; |
|---|
| 176 | if ( exists( $self->{plugin}{$datatype}{$plugintype} ) ) { |
|---|
| 177 | my $ref = $self->{plugin}{$datatype}{$plugintype}; |
|---|
| 178 | return ( $ref->{code}, @{ $ref->{arg} } ); |
|---|
| 179 | } |
|---|
| 180 | else { |
|---|
| 181 | return undef; |
|---|
| 182 | } |
|---|
| 183 | } |
|---|
| 184 | |
|---|
| 185 | =head2 logging($level, $message, ...) |
|---|
| 186 | |
|---|
| 187 | Pass a message into the logging process. |
|---|
| 188 | |
|---|
| 189 | $level is the level of message |
|---|
| 190 | $message and or other arguments are printf format string |
|---|
| 191 | |
|---|
| 192 | =cut |
|---|
| 193 | |
|---|
| 194 | sub logging { |
|---|
| 195 | my ( $self, $level, $fmt, @val ) = @_; |
|---|
| 196 | my $msg = sprintf( $fmt, @val ); |
|---|
| 197 | my $logh = $self->{loghandle}; |
|---|
| 198 | if ( $self->{logcallback} ) { |
|---|
| 199 | $self->{logcallback}->( $level, $msg ); |
|---|
| 200 | } |
|---|
| 201 | if ( $level >= 0 && $level >= $self->{verbose} ) { |
|---|
| 202 | if ($logh) { |
|---|
| 203 | printf $logh "%-9s %s %s\n", |
|---|
| 204 | sprintf( "[%s]", $self->loglevel($level) ), |
|---|
| 205 | strftime( "%b %d %H:%M:%S %Y", gmtime ), $msg; |
|---|
| 206 | } |
|---|
| 207 | } |
|---|
| 208 | $msg; |
|---|
| 209 | } |
|---|
| 210 | |
|---|
| 211 | =head2 loglevel($level) |
|---|
| 212 | |
|---|
| 213 | Return the text human readable log level associate to $level number |
|---|
| 214 | |
|---|
| 215 | =cut |
|---|
| 216 | |
|---|
| 217 | sub loglevel { |
|---|
| 218 | my $l = pop(@_); |
|---|
| 219 | defined($l) or $l = pop(@_); |
|---|
| 220 | return $loglevel[$l] || "?????"; |
|---|
| 221 | } |
|---|
| 222 | |
|---|
| 223 | =head2 checkconfig() |
|---|
| 224 | |
|---|
| 225 | Check the validity of information contains in configfile. |
|---|
| 226 | |
|---|
| 227 | Notice: This test does not include the syntaxe validity |
|---|
| 228 | |
|---|
| 229 | =cut |
|---|
| 230 | |
|---|
| 231 | sub checkconfig { |
|---|
| 232 | my ($self) = @_; |
|---|
| 233 | my $result = 1; |
|---|
| 234 | foreach my $g ( $self->{config}->GroupMembers('Obs') ) { |
|---|
| 235 | my ($obs) = $g =~ /\S+\s+(.*)/; |
|---|
| 236 | if ( !$self->{config}->SectionExists($obs) ) { |
|---|
| 237 | print STDERR "E: '$obs' is listed as Obs but it does not exists\n"; |
|---|
| 238 | next; |
|---|
| 239 | } |
|---|
| 240 | foreach my $param ( $self->{config}->Parameters($obs) ) { |
|---|
| 241 | } |
|---|
| 242 | foreach my $datatype ( $self->list_datatype ) { |
|---|
| 243 | foreach my $var (qw(match match_archive)) { |
|---|
| 244 | my $regexp = $self->getvalue( $datatype, $var ) |
|---|
| 245 | or next; # next ? are we sure ? |
|---|
| 246 | eval { qr/$regexp/ }; # Many thanks Rafael |
|---|
| 247 | if ($@) { |
|---|
| 248 | $self->logging( 4, "error in regexp for %s: '%s': %s", |
|---|
| 249 | $datatype, $regexp, $@, ); |
|---|
| 250 | $result = 0; |
|---|
| 251 | |
|---|
| 252 | # TODO set this reg unavalable |
|---|
| 253 | } |
|---|
| 254 | } |
|---|
| 255 | } |
|---|
| 256 | } |
|---|
| 257 | return ($result); |
|---|
| 258 | } |
|---|
| 259 | |
|---|
| 260 | =head2 getvalue($section, $var, $default) |
|---|
| 261 | |
|---|
| 262 | Return a value from the configuration, $default is assumed if the value is not set |
|---|
| 263 | |
|---|
| 264 | =cut |
|---|
| 265 | |
|---|
| 266 | sub getvalue { |
|---|
| 267 | my ( $self, $section, $var, $default ) = @_; |
|---|
| 268 | $self->{config}->val( $section, $var, $default ); |
|---|
| 269 | } |
|---|
| 270 | |
|---|
| 271 | =head2 config_mtime |
|---|
| 272 | |
|---|
| 273 | Return the modification time of config file currently used |
|---|
| 274 | |
|---|
| 275 | =cut |
|---|
| 276 | |
|---|
| 277 | sub config_mtime { |
|---|
| 278 | my ($self) = @_; |
|---|
| 279 | return $self->{configmtime} ||= ( stat( $self->{config}->GetFileName ) )[9]; |
|---|
| 280 | } |
|---|
| 281 | |
|---|
| 282 | =head2 list_obs |
|---|
| 283 | |
|---|
| 284 | Return the list of observatories defined in configuration |
|---|
| 285 | |
|---|
| 286 | =cut |
|---|
| 287 | |
|---|
| 288 | sub list_obs { |
|---|
| 289 | my ($self) = @_; |
|---|
| 290 | grep { $self->{config}->SectionExists($_) } |
|---|
| 291 | map { s/^\S+\s+//; $_ } $self->{config}->GroupMembers('Obs'); |
|---|
| 292 | } |
|---|
| 293 | |
|---|
| 294 | =head2 is_obs($obsname) |
|---|
| 295 | |
|---|
| 296 | Return True if $obsname is an observatory |
|---|
| 297 | |
|---|
| 298 | =cut |
|---|
| 299 | |
|---|
| 300 | sub is_obs { |
|---|
| 301 | my ( $self, $obs ) = @_; |
|---|
| 302 | scalar( grep { $_ eq "Obs $obs" } $self->{config}->GroupMembers('Obs') ); |
|---|
| 303 | } |
|---|
| 304 | |
|---|
| 305 | =head2 list_obsdatadir($obsname) |
|---|
| 306 | |
|---|
| 307 | Return a hash of data directories per data type for $obsname observatories |
|---|
| 308 | |
|---|
| 309 | =cut |
|---|
| 310 | |
|---|
| 311 | sub list_obsdatadir { |
|---|
| 312 | my ( $self, $obs ) = @_; |
|---|
| 313 | $self->is_obs($obs) or return undef; |
|---|
| 314 | map { |
|---|
| 315 | m,^datadir/(.*),; |
|---|
| 316 | ( ( $1 || "" ) => $self->{config}->val( $obs, $_ ) ) |
|---|
| 317 | } |
|---|
| 318 | grep { m,^datadir/, || $_ eq 'datadir' } |
|---|
| 319 | $self->{config}->Parameters($obs); |
|---|
| 320 | } |
|---|
| 321 | |
|---|
| 322 | =head2 list_typedatadir($type) |
|---|
| 323 | |
|---|
| 324 | List all directories for $type data |
|---|
| 325 | |
|---|
| 326 | =cut |
|---|
| 327 | |
|---|
| 328 | sub list_typedatadir { |
|---|
| 329 | my ( $self, $type ) = @_; |
|---|
| 330 | my %dirs; |
|---|
| 331 | foreach my $obs ( $self->list_obs ) { |
|---|
| 332 | $dirs{$_} = 1 foreach ( grep { $_ } $self->get_datadir( $obs, $type ) ); |
|---|
| 333 | } |
|---|
| 334 | keys %dirs; |
|---|
| 335 | |
|---|
| 336 | } |
|---|
| 337 | |
|---|
| 338 | =head2 get_datadir($obs, $type) |
|---|
| 339 | |
|---|
| 340 | Return a list of directories for $type data on $obs observatory |
|---|
| 341 | |
|---|
| 342 | =cut |
|---|
| 343 | |
|---|
| 344 | sub get_datadir { |
|---|
| 345 | my ( $self, $obs, $type ) = @_; |
|---|
| 346 | $self->is_obs($obs) or return undef; |
|---|
| 347 | grep { defined($_) } ( |
|---|
| 348 | $self->getvalue( $obs, "datadir/$type" ), |
|---|
| 349 | $self->getvalue( $obs, "datadir" ) |
|---|
| 350 | ); |
|---|
| 351 | } |
|---|
| 352 | |
|---|
| 353 | =head2 list_datatype |
|---|
| 354 | |
|---|
| 355 | Return a list of datatype handle by config |
|---|
| 356 | |
|---|
| 357 | =cut |
|---|
| 358 | |
|---|
| 359 | sub list_datatype { |
|---|
| 360 | my ($self) = @_; |
|---|
| 361 | grep { $_ ne 'global' } |
|---|
| 362 | grep { $_ !~ /^Obs\s+/ } |
|---|
| 363 | grep { !$self->is_obs($_) } $self->{config}->Sections; |
|---|
| 364 | } |
|---|
| 365 | |
|---|
| 366 | =head2 get_obs_data_handle($obs, $datatype) |
|---|
| 367 | |
|---|
| 368 | Return an ObsData::Repository object about directory for $obs station |
|---|
| 369 | about $datatype data. $datatype can be undefined if you want to get default |
|---|
| 370 | directory |
|---|
| 371 | |
|---|
| 372 | =cut |
|---|
| 373 | |
|---|
| 374 | sub get_obs_data_handle { |
|---|
| 375 | my ( $self, $obs, $datatype ) = @_; |
|---|
| 376 | |
|---|
| 377 | my $dir = |
|---|
| 378 | $self->getvalue( $obs, ( $datatype ? "datadir/$datatype" : "datadir" ) ); |
|---|
| 379 | if ( !$dir ) { |
|---|
| 380 | $self->logging( 4, "Can't find data directory for %s, type: %s", |
|---|
| 381 | $obs, $datatype || '(none)' ); |
|---|
| 382 | return undef; |
|---|
| 383 | } |
|---|
| 384 | my $or = ObsData::Repository::dir->new( |
|---|
| 385 | { |
|---|
| 386 | obsdata => $self, |
|---|
| 387 | dir => $dir, |
|---|
| 388 | obs => $obs, |
|---|
| 389 | datatype => $datatype, |
|---|
| 390 | dry_run => $self->{dry_run}, # FIXME does this have a better place ? |
|---|
| 391 | patern => $self->getvalue( |
|---|
| 392 | $obs, ( $datatype ? "searchfiles/$datatype" : "searchfiles" ) |
|---|
| 393 | ), |
|---|
| 394 | statusfile => $self->getvalue( |
|---|
| 395 | $obs, ( $datatype ? "index/$datatype" : "index" ), |
|---|
| 396 | "$dir/obsdata.ini" |
|---|
| 397 | ), |
|---|
| 398 | } |
|---|
| 399 | ); |
|---|
| 400 | if ( !defined($or) ) { |
|---|
| 401 | $self->logging( 4, "Can't parse %s, check directory exists", $dir ); |
|---|
| 402 | return undef; |
|---|
| 403 | } |
|---|
| 404 | |
|---|
| 405 | return ($or); |
|---|
| 406 | } |
|---|
| 407 | |
|---|
| 408 | =head2 process_obs($obs) |
|---|
| 409 | |
|---|
| 410 | Process all data handle by $obs station |
|---|
| 411 | |
|---|
| 412 | =cut |
|---|
| 413 | |
|---|
| 414 | sub process_obs { |
|---|
| 415 | my ( $self, $obs ) = @_; |
|---|
| 416 | my %datadir = $self->list_obsdatadir($obs); |
|---|
| 417 | $self->logging( 0, "Starting %s() for %s", ( caller(0) )[3], $obs ); |
|---|
| 418 | |
|---|
| 419 | foreach my $datatype ( keys %datadir ) { |
|---|
| 420 | my $or = $self->get_obs_data_handle( $obs, $datatype ); |
|---|
| 421 | $or or next; |
|---|
| 422 | $or->process; |
|---|
| 423 | } |
|---|
| 424 | } |
|---|
| 425 | |
|---|
| 426 | sub processed { |
|---|
| 427 | my ( $self, $obs, $archive, $datafile, $datatype, $dest ) = @_; |
|---|
| 428 | push( |
|---|
| 429 | @{ $self->{processed_lists} }, |
|---|
| 430 | { |
|---|
| 431 | obs => $obs, |
|---|
| 432 | archive => $archive, |
|---|
| 433 | datafile => $datafile, |
|---|
| 434 | datatype => $datatype, |
|---|
| 435 | destfile => $dest, |
|---|
| 436 | } |
|---|
| 437 | ); |
|---|
| 438 | $self->logging( 2, "Extraction of %s/%s done as %s", |
|---|
| 439 | $archive, $datafile, $dest, ) |
|---|
| 440 | if ($dest); |
|---|
| 441 | } |
|---|
| 442 | |
|---|
| 443 | sub generated_reported { |
|---|
| 444 | my ($self) = @_; |
|---|
| 445 | my $result = { |
|---|
| 446 | all => [], |
|---|
| 447 | users => {}, |
|---|
| 448 | }; |
|---|
| 449 | |
|---|
| 450 | foreach my $entry ( @{ $self->{processed_lists} } ) { |
|---|
| 451 | my %people = map { $_ => 1 } grep { $_ } ( |
|---|
| 452 | ( |
|---|
| 453 | $entry->{datatype} |
|---|
| 454 | ? split( /\s*,\s*/, |
|---|
| 455 | $self->getvalue( $entry->{datatype}, 'reportto' ) || "" ) |
|---|
| 456 | : split( |
|---|
| 457 | /\s*,\s*/, |
|---|
| 458 | $self->getvalue( 'global', 'nodestreportto' ) || "" |
|---|
| 459 | ) |
|---|
| 460 | ), |
|---|
| 461 | split( |
|---|
| 462 | /\s*,\s*/, $self->getvalue( $entry->{obs}, 'reportto' ) || "" |
|---|
| 463 | ), |
|---|
| 464 | split( |
|---|
| 465 | /\s*,\s*/, $self->getvalue( 'global', 'allreportto' ) || "" |
|---|
| 466 | ) |
|---|
| 467 | ); |
|---|
| 468 | keys %people or next; |
|---|
| 469 | foreach my $p ( keys %people ) { |
|---|
| 470 | push( @{ $result->{users}{$p} }, $entry ); |
|---|
| 471 | } |
|---|
| 472 | } |
|---|
| 473 | |
|---|
| 474 | foreach my $p ( keys( %{ $result->{users} || {} } ) ) { |
|---|
| 475 | my %obs_entries = (); |
|---|
| 476 | foreach ( @{ $result->{users}{$p} } ) { |
|---|
| 477 | push( @{ $obs_entries{ $_->{obs} } }, $_ ); |
|---|
| 478 | } |
|---|
| 479 | |
|---|
| 480 | foreach my $obs ( keys %obs_entries ) { |
|---|
| 481 | my %datatype_entries = (); |
|---|
| 482 | foreach ( @{ $obs_entries{$obs} } ) { |
|---|
| 483 | push( @{ $datatype_entries{ $_->{datatype} || '!' } }, $_ ); |
|---|
| 484 | } |
|---|
| 485 | |
|---|
| 486 | my %msg = ( |
|---|
| 487 | Subject => 'ObsData Report: ' |
|---|
| 488 | . $self->getvalue( $obs, 'description', $obs ), |
|---|
| 489 | To => $p, |
|---|
| 490 | 'X-ObsData-Version' => $VERSION, |
|---|
| 491 | 'X-ObsData-Obs' => $obs, |
|---|
| 492 | 'Content-Type' => "TEXT/PLAIN;\n charset=ISO-8859-15", |
|---|
| 493 | 'Content-Transfer-Encoding' => 'QUOTED-PRINTABLE', |
|---|
| 494 | From => $self->getvalue( |
|---|
| 495 | 'global', 'reportfrom', |
|---|
| 496 | 'ObsData <robot@aero.jussieu.fr>' |
|---|
| 497 | ), |
|---|
| 498 | ); |
|---|
| 499 | my $message = ""; |
|---|
| 500 | foreach my $d ( sort keys(%datatype_entries) ) { |
|---|
| 501 | if ( $d eq '!' ) { |
|---|
| 502 | $message .= "\nNot proceed:\n"; |
|---|
| 503 | foreach ( @{ $datatype_entries{$d} || [] } ) { |
|---|
| 504 | $message .= sprintf( " file %s from %s\n", |
|---|
| 505 | $_->{datafile}, $_->{archive}, ); |
|---|
| 506 | } |
|---|
| 507 | } |
|---|
| 508 | else { |
|---|
| 509 | $message .= "\nDataType: $d\n"; |
|---|
| 510 | foreach ( @{ $datatype_entries{$d} || [] } ) { |
|---|
| 511 | $message .= sprintf( " file %s from %s => %s\n", |
|---|
| 512 | $_->{datafile}, $_->{archive}, $_->{destfile}, ); |
|---|
| 513 | } |
|---|
| 514 | } |
|---|
| 515 | } |
|---|
| 516 | $message .= |
|---|
| 517 | sprintf( |
|---|
| 518 | "\n-- \nMail automatically generated by:\nObsdata Robot %s (SVN: %s)\n", |
|---|
| 519 | $VERSION, $CVSREV, ); |
|---|
| 520 | if ( |
|---|
| 521 | sendmail( |
|---|
| 522 | %msg, |
|---|
| 523 | smtp => 'mailhost', |
|---|
| 524 | Message => encode_qp($message), |
|---|
| 525 | ) |
|---|
| 526 | ) |
|---|
| 527 | { |
|---|
| 528 | $self->logging( |
|---|
| 529 | 1, |
|---|
| 530 | "Mail sent to %s for %s (%d files done)", |
|---|
| 531 | $p, $obs, |
|---|
| 532 | scalar( |
|---|
| 533 | map { @{ $datatype_entries{$_} || [] } } |
|---|
| 534 | keys(%datatype_entries) |
|---|
| 535 | ), |
|---|
| 536 | ); |
|---|
| 537 | } |
|---|
| 538 | else { |
|---|
| 539 | $self->logging( |
|---|
| 540 | 4, "Cannot send mail to %s: %s", |
|---|
| 541 | $msg{To}, $Mail::Sendmail::error, |
|---|
| 542 | ); |
|---|
| 543 | } |
|---|
| 544 | } |
|---|
| 545 | return $result; |
|---|
| 546 | } |
|---|
| 547 | } |
|---|
| 548 | |
|---|
| 549 | sub postprocessed { |
|---|
| 550 | my ($self) = @_; |
|---|
| 551 | my %datastype; |
|---|
| 552 | foreach my $entry ( @{ $self->{processed_lists} } ) { |
|---|
| 553 | $entry->{datatype} or next; |
|---|
| 554 | push( @{ $datastype{ $entry->{datatype} } }, $entry ); |
|---|
| 555 | } |
|---|
| 556 | |
|---|
| 557 | foreach my $datatype ( keys %datastype ) { |
|---|
| 558 | my $command = $self->getvalue( $datatype, 'postexec' ); |
|---|
| 559 | $self->logging( |
|---|
| 560 | 0, 'postexec for %s is %s', |
|---|
| 561 | $datatype, $command ? "`$command'" : 'not set, skipping', |
|---|
| 562 | ); |
|---|
| 563 | if ($command) { |
|---|
| 564 | if ( open( my $posthandle, "| $command" ) ) { |
|---|
| 565 | foreach ( @{ $datastype{$datatype} } ) { |
|---|
| 566 | print $posthandle "$_->{destfile}\n" or do { |
|---|
| 567 | $self->logging( 4, |
|---|
| 568 | "cannot write to postexec handle for `%s': %s", |
|---|
| 569 | $datatype, $!, ); |
|---|
| 570 | last; |
|---|
| 571 | }; |
|---|
| 572 | } |
|---|
| 573 | my $exitstatus = close($posthandle); |
|---|
| 574 | $self->logging( |
|---|
| 575 | $exitstatus ? 0 : 4, |
|---|
| 576 | "postexec for %s exit %s", |
|---|
| 577 | $datatype, |
|---|
| 578 | $exitstatus |
|---|
| 579 | ? "correctly" |
|---|
| 580 | : "with failure : " . ( $! ? ($!) : "(??)" ), |
|---|
| 581 | ); |
|---|
| 582 | } |
|---|
| 583 | else { |
|---|
| 584 | $self->logging( 4, "Cannot exec post `%s' for `%s'", |
|---|
| 585 | $command, $datatype, ); |
|---|
| 586 | next; |
|---|
| 587 | } |
|---|
| 588 | } |
|---|
| 589 | } |
|---|
| 590 | } |
|---|
| 591 | |
|---|
| 592 | 1; |
|---|
| 593 | |
|---|
| 594 | =head1 LICENSE |
|---|
| 595 | |
|---|
| 596 | This software is under GPL version 2 or highter |
|---|
| 597 | (c) 2005, 2006 CNRS Service d'Aeronomie |
|---|
| 598 | |
|---|
| 599 | =head1 AUTHOR |
|---|
| 600 | |
|---|
| 601 | Olivier Thauvin <olivier.thauvin@aerov.jussieu.fr> |
|---|
| 602 | |
|---|
| 603 | =cut |
|---|
| 604 | |
|---|
