1#! /usr/bin/perl -w 2# arclog: Archive the log files monthly 3 4# Copyright (c) 2001-2007 imacat 5# 6# This program is free software: you can redistribute it and/or modify 7# it under the terms of the GNU General Public License as published by 8# the Free Software Foundation, either version 3 of the License, or 9# (at your option) any later version. 10# 11# This program is distributed in the hope that it will be useful, 12# but WITHOUT ANY WARRANTY; without even the implied warranty of 13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14# GNU General Public License for more details. 15# 16# You should have received a copy of the GNU General Public License 17# along with this program. If not, see <http://www.gnu.org/licenses/>. 18 19# First written: 2001-01-05 20 21package main; 22use 5.008; 23use strict; 24use warnings; 25use ExtUtils::MakeMaker qw(); 26use Fcntl qw(:flock); 27use File::Basename qw(basename); 28use IO::Handle qw(autoflush); 29use Getopt::Long qw(GetOptions); 30use Cwd qw(cwd); 31use File::Basename qw(basename fileparse); 32use File::Spec::Functions qw(devnull file_name_is_absolute path catfile 33 splitdir curdir updir); 34use File::Temp qw(tempfile); 35use Config qw(); 36use base qw(Exporter); 37use vars qw(@EXPORT @EXPORT_OK); 38BEGIN { 39@EXPORT = qw(); 40push @EXPORT, qw(COMPRESS_GZIP COMPRESS_BZIP2 COMPRESS_NONE); 41push @EXPORT, qw(OVERRIDE_OVERWRITE OVERRIDE_APPEND OVERRIDE_IGNORE OVERRIDE_FAIL OVERRIDE_ASK); 42push @EXPORT, qw(KEEP_ALL KEEP_RESTART KEEP_DELETE KEEP_THISMONTH); 43push @EXPORT, qw(TYPE_PLAIN TYPE_GZIP TYPE_BZIP2); 44push @EXPORT, qw(TMP_SUFFIX whereis to_yyyymm format_number rel2abs); 45@EXPORT_OK = @EXPORT; 46# Prototype declaration 47sub main(); 48sub parse_args(); 49sub whereis($); 50sub to_yyyymm($); 51sub format_number($); 52sub rel2abs($;$); 53sub show_progress($$$); 54} 55 56our ($THIS_FILE, $VERBOSE); 57use vars qw($VERSION); 58$THIS_FILE = basename($0); 59$VERSION = "3.04"; 60$VERBOSE = 1; 61 62our (%CONF, @LOGFILES, $THIS_MONTH, $START, $LASTLINE); 63use vars qw(%WHEREIS); 64$THIS_MONTH = to_yyyymm $^T; 65 66# Constants 67# The compress mode 68use constant COMPRESS_GZIP => "gzip"; 69use constant COMPRESS_BZIP2 => "bzip2"; 70use constant COMPRESS_NONE => "none"; 71use constant DEFAULT_COMPRESS => COMPRESS_GZIP; 72# The override mode 73use constant OVERRIDE_OVERWRITE => "overwrite"; 74use constant OVERRIDE_APPEND => "append"; 75use constant OVERRIDE_IGNORE => "ignore"; 76use constant OVERRIDE_FAIL => "fail"; 77use constant OVERRIDE_ASK => "ask"; 78sub DEFAULT_OVERRIDE() { -t STDIN? OVERRIDE_ASK: OVERRIDE_FAIL; } 79# The keep mode 80use constant KEEP_ALL => "all"; 81use constant KEEP_RESTART => "restart"; 82use constant KEEP_DELETE => "delete"; 83use constant KEEP_THISMONTH => "this-month"; 84use constant DEFAULT_KEEP => KEEP_THISMONTH; 85# The file types 86use constant TYPE_PLAIN => "text/plain"; 87use constant TYPE_GZIP => "application/x-gzip"; 88use constant TYPE_BZIP2 => "application/x-bzip2"; 89# Other constants 90use constant TMP_SUFFIX => ".tmp-arclog"; 91use constant GZIP_SUFFIX => ".gz"; 92use constant BZIP2_SUFFIX => ".bz2"; 93use constant DEFAULT_PROGBAR => 1; 94use constant DEFAULT_SORT => 0; 95 96use vars qw($VERMSG $HELPMSG); 97our $SHORTHELP; 98$VERMSG = "$THIS_FILE v$VERSION by imacat <imacat\@mail.imacat.idv.tw>"; 99$SHORTHELP = "Try `$THIS_FILE --help' for more information."; 100$HELPMSG = << "EOT"; 101Usage: $THIS_FILE [options] logfile... [output] 102Archive the log files monthly. 103 104 logfile The log file to be archived. 105 output The prefix of the output files. The output files will be 106 named as pre.yyyymm, ie: pre.200001, pre.200002. If not 107 specified, the default prefix is the logfile pathname. 108 --compress method Compress the archived files. Available methods are: 109 gzip, bzip2 and none. The default is gzip. 110 --sort Sort the records in the log files by time. 111 --nosort Do not sort the records. (default) 112 --override mode The override behavior when the target archived files 113 exist. Available modes are: overwrite, append, ignore, 114 fail and ask. If not specified, the default is "ask" on 115 TTY, "fail" for else. 116 --keep mode What to keep in the logfile. Available modes are: all, 117 restart, delete and this-month. If not specified, the 118 default is "this-month". 119 -d,--debug Display debug messages. Multiple --debug to debug more. 120 -q,--quiet Disable debug messages. An opposite that cancels the 121 effect of --debug. 122 -h,--help Display this help. 123 -v,--version Display version number. 124 125EOT 126 127main; 128exit 0; 129 130# main: Main program 131sub main() { 132 local ($_, %_); 133 my %ARC; 134 135 # Parse the arguments 136 parse_args; 137 138 # Create the temporary working files 139 $_->create_temp foreach @LOGFILES; 140 # Read the source files to temporary working files 141 $_->read_source foreach @LOGFILES; 142 # Process each log file 143 %ARC = qw(); 144 foreach my $logfile (@LOGFILES) { 145 my ($label, $count, $dropped); 146 print STDERR "Archiving " . $logfile->{"file"} . " ... " 147 if $VERBOSE > 0 && !$CONF{"PROGBAR"}; 148 print STDERR "\n" if $VERBOSE > 1 && !$CONF{"PROGBAR"}; 149 $label = $logfile->{"file"}; 150 $label = "-" . substr($label, -13) if length $label > 14; 151 ($count, $dropped) = (0, 0); 152 # Sort each log record by month 153 while (defined($_ = $logfile->read_record)) { 154 my ($month, $FH); 155 $month = $logfile->{"format"}->parse_month($_); 156 # Skip malformed records whose time is not parsable 157 if (!defined $month) { 158 $dropped++; 159 160 # This month to keep 161 } elsif ($CONF{"KEEP"} eq KEEP_THISMONTH && $month eq $THIS_MONTH) { 162 $logfile->save_this_month($_); 163 164 # Months to archive 165 } else { 166 # A new month 167 $ARC{$month} = _private::Archive->new($month) 168 if !exists $ARC{$month}; 169 $ARC{$month}->add($_) if !$ARC{$month}->{"ignore"}; 170 } 171 $count++; 172 show_progress $label, $count, $logfile->{"count"} 173 if $CONF{"PROGBAR"}; 174 } 175 print STDERR "$count records\n" 176 if $VERBOSE > 0 && !$CONF{"PROGBAR"}; 177 warn "Dropping $dropped malformed records\n" 178 if $dropped > 0; 179 } 180 # Sorting 181 if ($CONF{"SORT"}) { 182 foreach my $month (sort grep !$ARC{$_}->{"ignore"}, keys %ARC) { 183 $ARC{$month}->sort; 184 } 185 } 186 # Store the archived log records 187 foreach my $month (sort grep !$ARC{$_}->{"ignore"}, keys %ARC) { 188 $ARC{$month}->store_archive; 189 } 190 # Return the records of this month 191 if ($CONF{"KEEP"} eq KEEP_THISMONTH) { 192 $_->restore_this_month foreach @LOGFILES; 193 } 194 # Remove the temporarily working files 195 $_->remove_temp foreach @LOGFILES; 196 197 # Print the statistics 198 printf STDERR "%d archive files written, %d seconds elapsed.\n", 199 scalar(grep !$ARC{$_}->{"ignore"}, keys %ARC), (time - $^T) 200 if $VERBOSE > 0; 201 return; 202} 203 204# parse_args: Parse the arguments 205sub parse_args() { 206 local ($_, %_); 207 my ($has_stdin, $one_arg); 208 209 %CONF = qw(); 210 $CONF{"SORT"} = DEFAULT_SORT; 211 # Get the arguments 212 eval { 213 local $SIG{"__WARN__"} = sub { die $_[0]; }; 214 Getopt::Long::Configure(qw(no_auto_abbrev bundling)); 215 GetOptions( "compress|c=s"=>sub { 216 if ($_[1] =~ /^(?:g|gzip)$/i) { 217 $CONF{"COMPRESS"} = COMPRESS_GZIP; 218 } elsif ($_[1] =~ /^(?:b|bzip2)$/i) { 219 $CONF{"COMPRESS"} = COMPRESS_BZIP2; 220 } elsif ($_[1] =~ /^(?:n|none)$/i) { 221 $CONF{"COMPRESS"} = COMPRESS_NONE; 222 } else { 223 die "$THIS_FILE: Unknown compress mode: $_[1]\n"; 224 } }, 225 "nocompress"=>sub { $CONF{"COMPRESS"} = COMPRESS_NONE; }, 226 "sort|s!"=>\$CONF{"SORT"}, 227 "override|o=s"=>sub { 228 if ($_[1] =~ /^(?:o|overwrite)$/i) { 229 $CONF{"OVERRIDE"} = OVERRIDE_OVERWRITE; 230 } elsif ($_[1] =~ /^(?:a|append)$/i) { 231 $CONF{"OVERRIDE"} = OVERRIDE_APPEND; 232 } elsif ($_[1] =~ /^(?:i|ignore)$/i) { 233 $CONF{"OVERRIDE"} = OVERRIDE_IGNORE; 234 } elsif ($_[1] =~ /^(?:f|fail)$/i) { 235 $CONF{"OVERRIDE"} = OVERRIDE_FAIL; 236 } elsif ($_[1] =~ /^(?:ask)$/i) { 237 $CONF{"OVERRIDE"} = OVERRIDE_ASK; 238 } else { 239 die "$THIS_FILE: Unknown override mode: $_[1]\n"; 240 } }, 241 "keep|k=s"=>sub { 242 if ($_[1] =~ /^(?:a|all)$/i) { 243 $CONF{"KEEP"} = KEEP_ALL; 244 } elsif ($_[1] =~ /^(?:r|restart)$/i) { 245 $CONF{"KEEP"} = KEEP_RESTART; 246 } elsif ($_[1] =~ /^(?:d|delete)$/i) { 247 $CONF{"KEEP"} = KEEP_DELETE; 248 } elsif ($_[1] =~ /^(?:t|this-month)$/i) { 249 $CONF{"KEEP"} = KEEP_THISMONTH; 250 } else { 251 die "$THIS_FILE: Unknown keep mode: $_[1]\n"; 252 } }, 253 "debug|d+"=>\$VERBOSE, 254 "quiet|q"=>sub { $VERBOSE-- if $VERBOSE > 0; }, 255 "help|h"=>sub { print $HELPMSG; exit 0; }, 256 "version|v"=>sub { print "$VERMSG\n"; exit 0; }); 257 }; 258 die "$THIS_FILE: $@$SHORTHELP\n" if $@ ne ""; 259 260 # Save the original STDIN and STDOUT 261 open $STDIN, "<&", \*STDIN or die "$THIS_FILE: STDIN: $!"; 262 open $STDOUT, ">&", \*STDOUT or die "$THIS_FILE: STDOUT: $!"; 263 264 # Set the verbose level 265 autoflush STDERR if $VERBOSE > 1; 266 $CONF{"PROGBAR"} = DEFAULT_PROGBAR; 267 $CONF{"PROGBAR"} = 0 if $VERBOSE == 0 || !-t STDERR; 268 if ($CONF{"PROGBAR"}) { 269 # Check if we have Term::ReadKey 270 $CONF{"PROGBAR"} = 0 unless eval { require Term::ReadKey; 1; }; 271 } 272 273 # Check the arguments 274 # Arguments are source files 275 @LOGFILES = qw(); 276 while (@ARGV > 0) { 277 $_ = shift @ARGV; 278 # Treat /dev/stdin as - on UNIX-like systems 279 $_ = "-" if $_ eq "/dev/stdin" && devnull eq "/dev/null"; 280 push @LOGFILES, $_; 281 $_{$_} = 1; 282 } 283 die "$THIS_FILE: Which log file do you want to archive?\n$SHORTHELP\n" 284 if @LOGFILES == 0; 285 $has_stdin = scalar grep $_ eq "-", @LOGFILES; 286 # The output prefix 287 $one_arg = (@LOGFILES == 1); 288 if ($one_arg) { 289 # STDIN must specify the output prefix 290 die "$THIS_FILE: You must specify the output prefix for STDIN\n$SHORTHELP\n" 291 if $LOGFILES[0] eq "-"; 292 $CONF{"OUTPUT"} = $LOGFILES[0]; 293 } else { 294 $CONF{"OUTPUT"} = pop @LOGFILES; 295 die "$THIS_FILE: You cannot specify STDOUT as the output prefix\n$SHORTHELP\n" 296 if $CONF{"OUTPUT"} eq "-"; 297 } 298 # Check the duplicates - after removing the output prefix 299 %_ = qw(); 300 foreach (@LOGFILES) { 301 die "$THIS_FILE: $_: You can only specify a file once\n$SHORTHELP\n" 302 if exists $_{$_}; 303 $_{$_} = 1; 304 } 305 306 # Set the default override mode 307 $CONF{"OVERRIDE"} = DEFAULT_OVERRIDE if !exists $CONF{"OVERRIDE"}; 308 # Set the default keep mode 309 $CONF{"KEEP"} = DEFAULT_KEEP if !exists $CONF{"KEEP"}; 310 # Set the default compress mode 311 $CONF{"COMPRESS"} = DEFAULT_COMPRESS if !exists $CONF{"COMPRESS"}; 312 313 # Cannot keep the records of this month back in STDIN 314 if ($has_stdin && $CONF{"KEEP"} eq KEEP_THISMONTH) { 315 warn "$THIS_FILE: Cannot keep this-month in STDIN. Change to keep all.\n"; 316 $CONF{"KEEP"} = KEEP_ALL; 317 } 318 # Cannot delete STDIN 319 if ($has_stdin && $CONF{"KEEP"} eq KEEP_DELETE) { 320 warn "$THIS_FILE: Cannot delete the STDIN. Change to keep all.\n"; 321 $CONF{"KEEP"} = KEEP_ALL; 322 } 323 # Cannot restart STDIN 324 if ($has_stdin && $CONF{"KEEP"} eq KEEP_RESTART) { 325 warn "$THIS_FILE: Cannot restart the STDIN. Change to keep all.\n"; 326 $CONF{"KEEP"} = KEEP_ALL; 327 } 328 # Cannot get the log file and the answer both from STDIN 329 if ($has_stdin && $CONF{"OVERRIDE"} eq OVERRIDE_ASK) { 330 warn "$THIS_FILE: Cannot read from STDIN in ask mode. Change to fail mode.\n"; 331 $CONF{"OVERRIDE"} = "fail"; 332 } 333 334 # Check the log files 335 @LOGFILES = map new _private::LogFile($_), @LOGFILES; 336 if ((@_ = grep $_->{"is_empty"}, @LOGFILES) > 0) { 337 print STDERR "Skipping empty files: " . join(", ", map $_->{"file"}, @_) . "\n" 338 if $VERBOSE > 0; 339 @LOGFILES = grep !$_->{"is_empty"}, @LOGFILES; 340 # Close empty files - do this after $_->{"is_empty"}, 341 # so that $_->{"is_empty"} is still accessible. 342 foreach (@_) { 343 $_->{"io"}->close; 344 undef $_; 345 } 346 if (@LOGFILES == 0) { 347 print STDERR "$THIS_FILE: No non-empty files left. Exiting.\n" 348 if $VERBOSE > 0; 349 exit 0; 350 } 351 $has_stdin = scalar grep $_->{"stdin"}, @LOGFILES; 352 } 353 # Check if the formats of the files are consistent 354 %_ = map { $_->{"format"} => 1 } @LOGFILES; 355 die "$THIS_FILE: Cannot archive log files in different formats at a time.\n" 356 . join "", map sprintf(" %s : %s\n", $_->{"file"}, $_->{"format"}), 357 @LOGFILES 358 if keys %_ > 1; 359 $CONF{"FORMAT"} = $LOGFILES[0]->{"format"}; 360 361 # Check the output file prefix 362 # Strip the filename suffix of the compressed files 363 if ($one_arg) { 364 $CONF{"OUTPUT"} =~ s/\.gz$// if $LOGFILES[0]->{"type"} eq TYPE_GZIP; 365 $CONF{"OUTPUT"} =~ s/\.bz2$// if $LOGFILES[0]->{"type"} eq TYPE_BZIP2; 366 } 367 die "$THIS_FILE: Please specify output prefix\n$SHORTHELP\n" 368 if !defined $CONF{"OUTPUT"}; 369 $CONF{"OUTPUT"} = rel2abs $CONF{"OUTPUT"}; 370 $_ = (fileparse $CONF{"OUTPUT"})[1]; 371 die "$THIS_FILE: $_: Not found\n$SHORTHELP\n" 372 if !-e $_; 373 die "$THIS_FILE: $_: Not a directory\n$SHORTHELP\n" 374 if !-d $_; 375 die "$THIS_FILE: $_: Permission denied\n$SHORTHELP\n" 376 if !-w $_; 377 378 return; 379} 380 381# whereis: Find an executable 382# Code inspired from CPAN::FirstTime 383sub whereis($) { 384 local ($_, %_); 385 my ($file, $path); 386 $file = $_[0]; 387 return $WHEREIS{$file} if exists $WHEREIS{$file}; 388 foreach my $dir (path) { 389 print STDERR " Checking $dir ... " if $VERBOSE > 3; 390 if (defined($path = MM->maybe_command(catfile($dir, $file)))) { 391 print STDERR "$path\n found " if $VERBOSE > 3; 392 return ($WHEREIS{$file} = $path); 393 } 394 print STDERR "no\n" if $VERBOSE > 3; 395 } 396 return ($WHEREIS{$file} = undef); 397} 398 399# to_yyyymm: convert timestamp to yyyymm 400sub to_yyyymm($) { 401 local ($_, %_); 402 @_ = localtime $_[0]; 403 return sprintf "%04d%02d", $_[5] + 1900, $_[4] + 1; 404} 405 406# format_number: Format the number every 3 digit 407sub format_number($) { 408 local $_; 409 $_ = $_[0]; 410 # Group every 3 digit 411 $_ = $1 . "," . $2 . $3 while /^([^\.]*\d)(\d\d\d)(.*)$/; 412 return $_; 413} 414 415# rel2abs: Convert a relative path to an absolute path 416sub rel2abs($;$) { 417 local ($_, %_); 418 my ($path, $base); 419 ($path, $base) = @_; 420 421 # Turn the base absolute 422 $base = cwd unless defined $base; 423 $base = rel2abs $base if !file_name_is_absolute $base; 424 425 # Deal with the ~ user home directories under UNIX 426 if (defined $Config::Config{"d_getpwent"}) { 427 @_ = splitdir($path); 428 # If it starts from the user home directory 429 if ($_[0] =~ /^~(.*)$/) { 430 my ($user, @pwent, $home); 431 $user = $1; 432 # The same as the current user 433 if ( (@pwent = getpwuid $>) > 0 434 && ($user eq "" || $user eq $pwent[0])) { 435 # Replace with the user home directory 436 # Respect the HOME environment variable if exists 437 $home = exists $ENV{"HOME"}? $ENV{"HOME"}: $pwent[7]; 438 @_ = (splitdir($home), @_[1...$#_]); 439 # Get the user home directory 440 } elsif ((@pwent = getpwnam $user) > 0) { 441 # Replace with the user home directory 442 $home = $pwent[7]; 443 @_ = (splitdir($home), @_[1...$#_]); 444 } 445 # Compose the path 446 $path = catfile @_; 447 } 448 } 449 450 # Append the current directory if relative 451 $path = catfile($base, $path) unless file_name_is_absolute $path; 452 453 @_ = splitdir($path); # Split into directory components 454 # Add an empty filename level if last level is a directory 455 push @_, "" if ($_[@_-1] eq curdir || $_[@_-1] eq updir); 456 for ($_ = 1; $_ < @_; $_++) { # Parse each level one by one 457 # If it is this directory 458 if ($_[$_] eq curdir) { 459 splice @_, $_, 1; # Remove this level directly 460 $_--; # The level number drop by 1 461 # If it is the parent directory 462 } elsif ($_ > 1 && $_[$_] eq updir && $_[$_-1] ne updir) { 463 splice @_, $_-1, 2; # Remove this and the previous level 464 $_ -= 2; # The level number drop by 2 465 } 466 } 467 $path = catfile @_; # Compose the full path 468 return $path; 469} 470 471# show_progress: Show a progress bar 472sub show_progress($$$) { 473 local ($_, %_); 474 my ($label, $cur, $total, $line, $width, $bar, $elapsed, $m, $s); 475 ($label, $cur, $total) = @_; 476 477 # Disable line buffer 478 $| = 1; 479 # Not enough space for a progress bar 480 return if ($width = (Term::ReadKey::GetTerminalSize())[0] - 30) < 1; 481 # Start the timer 482 $START = time if !defined $START; 483 # Calculate the elapsed time 484 $elapsed = time - $START; 485 $s = $elapsed % 60; 486 $m = ($elapsed - $s) / 60; 487 # Calculate the percentage and the progress bar 488 $bar = "*" x sprintf("%1.0f", ($cur / $total) * $width); 489 # Compose the line 490 $line = sprintf "\r%-14.14s |%-".$width."s| %3.0f%% %02d:%02d", 491 $label, $bar, ($cur / $total) * 100, $m, $s; 492 # Print if changed 493 if (!defined $LASTLINE || $LASTLINE ne $line) { 494 # Print it 495 print STDERR "\r$line"; 496 # Record the current line 497 $LASTLINE = $line; 498 } 499 # Finished 500 if ($cur == $total) { 501 print STDERR "\n"; 502 undef $START; 503 } 504 return; 505} 506 507 508# _private::LogFile: The source log file 509package _private::LogFile; 510use 5.008; 511use strict; 512use warnings; 513BEGIN { 514import main; 515} 516 517use Fcntl qw(:flock :seek); 518use File::Basename qw(fileparse); 519use File::Temp qw(tempfile); 520 521# Constants 522# The file type checkers 523use constant MAGIC_PM => "File::MMagic"; 524use constant MAGIC_EXEC => "file"; 525use constant MAGIC_SUFFIX => "suffix"; 526 527use vars qw($MAGIC_METHOD $MAGIC $GZIP_IO $BZIP2_IO); 528undef $MAGIC_METHOD; 529 530# new: Initialize the source log file processer 531sub new : method { 532 local ($_, %_); 533 my ($class, $self, $file, $FH, $f0); 534 ($class, $file) = @_; 535 536 # STDIN is another class 537 if ($file eq "-") { 538 $class .= "::STDIN"; 539 return $class->new(@_[1...$#_]); 540 } 541 542 $self = bless {}, $class; 543 $self->{"stdin"} = 0; 544 $self->{"keep"} = $CONF{"KEEP"}; 545 $self->{"override"} = $CONF{"OVERRIDE"}; 546 $self->{"tmp"} = undef; 547 548 # Load the File::MMagic first before opening anything, or the seek 549 # method will not be loaded into IO::Handle 550 $self->check_magic; 551 $self->{"checktype"} = $file if $MAGIC_METHOD eq MAGIC_EXEC; 552 553 $self->{"file"} = rel2abs $file; 554 ($f0, $file) = ($file, $self->{"file"}); 555 # Open the file 556 if ($self->{"keep"} eq KEEP_ALL) { 557 open $FH, $file or die "$THIS_FILE: $file: $!"; 558 flock $FH, LOCK_SH; 559 } else { 560 open $FH, "+<", $file or die "$THIS_FILE: $file: $!"; 561 flock $FH, LOCK_EX; 562 } 563 $self->{"FH"} = $FH; 564 565 # Check the file type 566 print STDERR "Checking file type of $f0 ... " if $VERBOSE > 1; 567 $self->{"type"} = $self->check_type; 568 print STDERR $self->{"type"} . "\n" if $VERBOSE > 1; 569 # Check the I/O handler to use 570 $self->{"io"} = $self->check_io; 571 # Open the file 572 $self->{"io"}->open_read($file, $self->{"FH"}); 573 # Check the log file fromat 574 $self->{"format"} = $self->check_format; 575 # Not empty 576 if (!$self->{"is_empty"}) { 577 # Check the temporarily working file availability 578 $self->{"temp"} = $self->check_temp; 579 } 580 581 return $self; 582} 583 584# check_temp: Check the temporarily working file availability 585sub check_temp : method { 586 local ($_, %_); 587 my ($self, $file, $dir, $suf); 588 $self = $_[0]; 589 590 # No need to create a named temporarily file if we keep the log file 591 if ($CONF{"KEEP"} eq KEEP_ALL) { 592 # Create an anonymous temporary file 593 return undef; 594 } 595 596 if ($self->{"type"} eq TYPE_GZIP) { 597 ($file, $dir, $suf) = fileparse $self->{"file"}, ".gz"; 598 } elsif ($self->{"type"} eq TYPE_BZIP2) { 599 ($file, $dir, $suf) = fileparse $self->{"file"}, ".bz2"; 600 } else { 601 ($file, $dir, $suf) = fileparse $self->{"file"}; 602 } 603 604 $_ = $dir . $file . TMP_SUFFIX; 605 # Does the temporary working file exists? 606 die "$THIS_FILE: $_: Temporary working file exists\n$SHORTHELP\n" 607 if -e $_; 608 609 # Check if we can create the temporarily working file 610 die "$THIS_FILE: $dir: File exists\n$SHORTHELP\n" 611 if !-e $dir; 612 die "$THIS_FILE: $dir: Not a directory\n$SHORTHELP\n" 613 if !-d $dir; 614 die "$THIS_FILE: $dir: Permission denied\n$SHORTHELP\n" 615 if !-w $dir; 616 617 return $_; 618} 619 620# check_format: Check the log file fromat 621sub check_format : method { 622 local ($_, %_); 623 my $self; 624 $self = $_[0]; 625 626 # Read the first line from the source file 627 $self->{"first_line"} = $self->{"io"}->readline; 628 # Skip empty files 629 $self->{"is_empty"} = !defined $self->{"first_line"}; 630 if ($self->{"is_empty"}) { 631 print STDERR "File is empty.\n" if $VERBOSE > 1; 632 return undef; 633 } 634 635 # Check the log file format 636 print STDERR "Checking the log file format... " if $VERBOSE > 1; 637 print STDERR "\n" if $VERBOSE > 2; 638 $_ = _private::Format->check_format($self->{"first_line"}); 639 # Unrecognized log record 640 if (!defined $_) { 641 print STDERR "unknown\n" if $VERBOSE > 1; 642 die "$THIS_FILE: Unrecognized log file format"; 643 } 644 print STDERR "$_\n" if $VERBOSE > 1; 645 return $_; 646} 647 648# create_temp: Create the temporary working file 649sub create_temp : method { 650 local ($_, %_); 651 my ($self, $temp, $FHT); 652 $self = $_[0]; 653 654 # Create a named temporarily working file 655 if (defined $self->{"temp"}) { 656 $temp = $self->{"temp"}; 657 print STDERR "Creating $temp ... " if $VERBOSE > 2; 658 open $FHT, "+>", $temp or die "$THIS_FILE: $temp: $!"; 659 flock $FHT, LOCK_EX; 660 $self->{"FHT"} = $FHT; 661 print STDERR "done\n" if $VERBOSE > 2; 662 return $FHT; 663 664 # Create an anonymous temporarily working file 665 } else { 666 print STDERR "Creating temporary working file for " . $self->{"file"} . " ... " 667 if $VERBOSE > 2; 668 $self->{"FHT"} = tempfile or die "$THIS_FILE: tempfile: $!"; 669 flock $self->{"FHT"}, LOCK_EX; 670 print STDERR "done\n" if $VERBOSE > 2; 671 return $self->{"FHT"}; 672 } 673} 674 675# remove_temp: Remove the temporary working file 676sub remove_temp : method { 677 local ($_, %_); 678 my ($self, $temp, $FHT); 679 $self = $_[0]; 680 ($FHT, $temp) = ($self->{"FHT"}, $self->{"temp"}); 681 # A named temporarily file 682 if (defined $self->{"temp"}) { 683 print STDERR "Removing $temp ... " if $VERBOSE > 2; 684 close $FHT or die "$THIS_FILE: $temp: $!"; 685 unlink $temp or die "$THIS_FILE: $temp: $!"; 686 print STDERR "done\n" if $VERBOSE > 2; 687 688 # An anonymous temporarily working file 689 } else { 690 print STDERR "Closing temporary working file ... " if $VERBOSE > 2; 691 close $FHT or die "$THIS_FILE: tempfile: $!"; 692 print STDERR "done\n" if $VERBOSE > 2; 693 } 694 return; 695} 696 697# read_source: Read the source file 698sub read_source : method { 699 local ($_, %_); 700 my ($self, $file, $FHT, $count); 701 $self = $_[0]; 702 ($file, $FHT) = ($self->{"file"}, $self->{"FHT"}); 703 print STDERR "Reading from $file ... " if $VERBOSE > 1; 704 print STDERR "\n" if $VERBOSE > 2; 705 print STDERR " Reading source records ... " if $VERBOSE > 2; 706 $count = 0; 707 # The first line is already read, to determine the format 708 $_ = $self->{"first_line"}; 709 print $FHT $_ or die "$THIS_FILE: tempfile: $!"; 710 $count++; 711 # The rest lines 712 while (defined($_ = $self->{"io"}->readline)) { 713 print $FHT $_ or die "$THIS_FILE: tempfile: $!"; 714 $count++; 715 } 716 print STDERR "$count records\n" if $VERBOSE > 2; 717 $self->{"io"}->close($self->{"keep"}, $self->{"tmp"}); 718 print STDERR "$count records\n" if $VERBOSE > 1; 719 $self->{"count"} = $count; 720 return $count;; 721} 722 723# read_record: Read a record, returning the record and its month 724sub read_record : method { 725 local ($_, %_); 726 my ($self, $FHT, $record, $month); 727 $self = $_[0]; 728 $FHT = $self->{"FHT"}; 729 # Reset when start reading 730 if (!exists $self->{"reading_record"}) { 731 seek $FHT, 0, SEEK_SET or die "$THIS_FILE: tempfile: $!"; 732 $self->{"reading_record"} = 1; 733 } 734 $_ = <$FHT>; 735 # End of read 736 delete $self->{"reading_record"} if !defined $_; 737 return $_; 738} 739 740# save_this_month: Save the records of this month 741sub save_this_month : method { 742 local ($_, %_); 743 my ($self, $record, $FH); 744 ($self, $record) = @_; 745 # Create the temporary saving space 746 if (!exists $self->{"FHTH"}) { 747 print STDERR "\n" if $VERBOSE > 2 && defined $START; 748 print STDERR " Creating buffer for this month ... " 749 if $VERBOSE > 2; 750 $FH = tempfile or die "$THIS_FILE: tempfile: $!"; 751 flock $FH, LOCK_EX or die "$THIS_FILE: tempfile: $!"; 752 print STDERR "done\n" if $VERBOSE > 2; 753 $self->{"FHTH"} = $FH; 754 $self->{"count_thismonth"} = 0; 755 $self->{"size_thismonth"} = 0; 756 } else { 757 $FH = $self->{"FHTH"}; 758 } 759 # Save the record 760 print $FH $record or die "$THIS_FILE: tempfile: $!"; 761 $self->{"count_thismonth"}++; 762 $self->{"size_thismonth"} += length $record; 763 return; 764} 765 766# restore_this_month: Return the records of this month to the log file 767sub restore_this_month : method { 768 local ($_, %_); 769 my ($self, $file, $FH, $count); 770 $self = $_[0]; 771 # Bounce if no record to restore 772 return unless exists $self->{"FHTH"}; 773 ($file, $FH) = ($self->{"file"}, $self->{"FHTH"}); 774 775 # Prepend the records using the I/O class implementation 776 ref($self->{"io"})->prepend_records($file, $FH); 777 778 # Report the statistics 779 printf STDERR "%s: keeping %s records, %s bytes\n", 780 $file, format_number($self->{"count_thismonth"}), 781 format_number($self->{"size_thismonth"}) 782 if $VERBOSE > 0; 783 784 return; 785} 786 787# check_type: Check the source file type 788sub check_type : method { 789 local ($_, %_); 790 my ($self, $file, $FH, $PH, $CMD); 791 $self = $_[0]; 792 ($file, $FH) = ($self->{"file"}, $self->{"FH"}); 793 794 # Check the file type checker to use 795 $self->check_magic; 796 die "$THIS_FILE: Cannot check STDIN from the filename suffix.\n" 797 if $self->{"stdin"} && $MAGIC_METHOD eq MAGIC_SUFFIX; 798 799 # Check by file name suffix 800 if ($MAGIC_METHOD eq MAGIC_SUFFIX) { 801 return TYPE_GZIP if $file =~ /\.gz$/; 802 return TYPE_BZIP2 if $file =~ /\.bz2$/; 803 # Otherwise we assume it to be text/plain 804 return TYPE_PLAIN; 805 } 806 807 # Check the file format 808 # Check by File::MMagic 809 if ($MAGIC_METHOD eq MAGIC_PM) { 810 $_ = $MAGIC->checktype_filehandle($FH); 811 seek $FH, 0, SEEK_SET or die "$THIS_FILE: $file: $!"; 812 813 # Check by the file program 814 } elsif ($MAGIC_METHOD eq MAGIC_EXEC) { 815 flock $FH, LOCK_UN; 816 @_ = ($MAGIC, $self->{"checktype"}); 817 @_ = map "\"$_\"", @_ if $^O eq "MSWin32"; 818 $CMD = join " ", @_; 819 # Start the process 820 if ($^O eq "MSWin32") { 821 open $PH, "$CMD |" or die "$THIS_FILE: $CMD: $!"; 822 } else { 823 open $PH, "-|", @_ or die "$THIS_FILE: $CMD: $!"; 824 } 825 $_ = join "", <$PH>; 826 close $PH or die "$THIS_FILE: $CMD: $!"; 827 if ($self->{"keep"} eq KEEP_ALL) { 828 flock $FH, LOCK_SH; 829 } else { 830 flock $FH, LOCK_EX; 831 } 832 } 833 834 # Check the returned file type text 835 return TYPE_GZIP if /gzip/i; 836 return TYPE_BZIP2 if /bzip2/i; 837 # Default everything to text/plain 838 return TYPE_PLAIN; 839} 840 841# check_io: Check the I/O handler to use 842sub check_io : method { 843 local ($_, %_); 844 my $self; 845 $self = $_[0]; 846 # We need a gzip compression I/O handler 847 return _private::IO->check_gzip if $self->{"type"} eq TYPE_GZIP; 848 # We need a bzip2 compression I/O handler 849 return _private::IO->check_bzip2 if $self->{"type"} eq TYPE_BZIP2; 850 # We need a plain I/O handler 851 return _private::IO::Plain->new; 852} 853 854# check_magic: Check the file type checker to use 855sub check_magic : method { 856 local ($_, %_); 857 my $self; 858 $self = $_[0]; 859 860 # Checked before 861 return $MAGIC_METHOD if defined $MAGIC_METHOD; 862 863 print STDERR "Checking file type checker to use ... " if $VERBOSE > 1; 864 print STDERR "\n Checking File::MMagic ... " if $VERBOSE > 2; 865 # Check if we have File::MMagic 866 if (eval { require File::MMagic; 1; }) { 867 print STDERR "OK\nfound " if $VERBOSE > 2; 868 print STDERR "File::MMagic\n" if $VERBOSE > 1; 869 $MAGIC = File::MMagic->new; 870 return ($MAGIC_METHOD = MAGIC_PM); 871 } 872 # Not found 873 print STDERR "no\n" if $VERBOSE > 2; 874 $@ =~ s/^(Can't locate \S+ in \@INC).*\n/$1\n/; # ' 875 warn "$@" if $VERBOSE == 1; 876 877 # Looking for file from PATH 878 print STDERR " Checking file ... " if $VERBOSE > 2; 879 # Found in PATH 880 if (defined($MAGIC = whereis "file")) { 881 print STDERR "$MAGIC\nfound " if $VERBOSE > 2; 882 print STDERR "$MAGIC\n" if $VERBOSE > 1; 883 warn "$THIS_FILE: We will check with $MAGIC instead\n" 884 if $VERBOSE > 0; 885 return ($MAGIC_METHOD = MAGIC_EXEC); 886 } 887 # Not found 888 print STDERR "no\n" if $VERBOSE > 2; 889 890 # Check by file name suffix 891 print STDERR " Fall back using file name suffix instead\n" if $VERBOSE > 2; 892 print STDERR "file name suffix\n" if $VERBOSE > 1; 893 warn "$THIS_FILE: We will check by file name suffix instead\n" 894 if $VERBOSE == 1; 895 return ($MAGIC_METHOD = MAGIC_SUFFIX); 896} 897 898 899# _private::LogFile::STDIN: The source log file as STDIN 900package _private::LogFile::STDIN; 901use 5.008; 902use strict; 903use warnings; 904use base qw(_private::LogFile); 905BEGIN { 906import main; 907} 908 909use IO::Handle; 910use Fcntl qw(:flock :seek); 911use File::Temp qw(tempfile unlink0); 912 913# new: Initialize the source log file processer 914sub new : method { 915 local ($_, %_); 916 my ($class, $self, $file, $FH, $tmp); 917 ($class, $file) = @_; 918 919 # We only initialize STDIN 920 return $file if ref($file) ne "" || $file ne "-"; 921 922 $self = bless {}, $class; 923 $self->{"stdin"} = 1; 924 $self->{"keep"} = KEEP_ALL; 925 $self->{"override"} = OVERRIDE_OVERWRITE; 926 $self->{"tmp"} = undef; 927 928 # Load the File::MMagic first before opening anything, or the seek 929 # method will not be loaded into IO::Handle 930 $self->check_magic; 931 932 # Save STDIN to somewhere 933 $file = "the STDIN buffer"; 934 if ($_private::LogFile::MAGIC_METHOD eq _private::LogFile::MAGIC_EXEC) { 935 ($FH, $tmp) = tempfile(undef, UNLINK => 1) 936 or die "$THIS_FILE: tempfile: $!"; 937 $self->{"checktype"} = $tmp; 938 $self->{"tmp"} = $tmp; 939 } else { 940 undef $tmp; 941 $FH = tempfile or die "$THIS_FILE: tempfile: $!"; 942 } 943 ($self->{"FH"}, $self->{"file"}) = ($FH, $file); 944 flock $FH, LOCK_EX; 945 print STDERR "Saving STDIN to a buffer ... " if $VERBOSE > 1; 946 while (defined($_ = <STDIN>)) { 947 print $FH $_ or die "$THIS_FILE: $file: $!"; 948 } 949 seek $FH, 0, SEEK_SET or die "$THIS_FILE: $file: $!"; 950 print STDERR "done\n" if $VERBOSE > 1; 951 952 # Check the file type 953 print STDERR "Checking file type of STDIN ... " if $VERBOSE > 1; 954 $self->{"type"} = $self->check_type; 955 # Unlink after check_type() with file executable 956 if ($_private::LogFile::MAGIC_METHOD eq _private::LogFile::MAGIC_EXEC) { 957 unlink0($FH, $tmp) or die "$THIS_FILE: $tmp: $!"; 958 } 959 print STDERR $self->{"type"} . "\n" if $VERBOSE > 1; 960 # Check the I/O handler to use 961 $self->{"io"} = $self->check_io; 962 # Open the file 963 $self->{"io"}->open_read($file, $self->{"FH"}); 964 # Check the log file fromat 965 $self->{"format"} = $self->check_format; 966 # STDIN always goes to an anonymous temporarily working file 967 $self->{"temp"} = undef; 968 969 return $self; 970} 971 972# remove_temp: Remove the temporary working file 973sub remove_temp : method { 974 local ($_, %_); 975 $_ = $_[0]; 976 print STDERR "Closing temporary working file for STDIN ... " if $VERBOSE > 2; 977 close $_->{"FHT"} or die "$THIS_FILE: tempfile: $!"; 978 print STDERR "done\n" if $VERBOSE > 2; 979 return; 980} 981 982 983# _private::Archive: The result archived log file 984package _private::Archive; 985use 5.008; 986use strict; 987use warnings; 988BEGIN { 989import main; 990} 991 992use Date::Parse qw(str2time); 993use Fcntl qw(:flock :seek); 994use File::Basename qw(basename); 995use File::Temp qw(tempfile); 996 997# new: Initialize the result archive file processer 998sub new : method { 999 local ($_, %_); 1000 my ($class, $self, $month, $file, $FH); 1001 ($class, $month) = @_; 1002 $self = bless {}, $class; 1003 $self->{"month"} = $month; 1004 $self->{"override"} = $CONF{"OVERRIDE"}; 1005 $self->{"format"} = $CONF{"FORMAT"}; 1006 if ($CONF{"COMPRESS"} eq COMPRESS_GZIP) { 1007 $self->{"io"} = _private::IO->check_gzip; 1008 } elsif ($CONF{"COMPRESS"} eq COMPRESS_BZIP2) { 1009 $self->{"io"} = _private::IO->check_bzip2; 1010 } else { 1011 $self->{"io"} = _private::IO::Plain->new; 1012 } 1013 # The resulted output file 1014 $self->{"file"} = $CONF{"OUTPUT"} . "." . $month 1015 . $self->{"io"}->suffix; 1016 $file = $self->{"file"}; 1017 $self->{"ignore"} = 0; 1018 # The resulted output file exists 1019 if (-e $file) { 1020 # If we should ask 1021 # Jump off the progress bar 1022 print STDERR "\n" 1023 if $self->{"override"} eq OVERRIDE_ASK && defined $START; 1024 while ($self->{"override"} eq OVERRIDE_ASK) { 1025 printf STDERR "$file exists, (O)verwrite, (A)ppend, (I)gnore, (F)ail? [F] "; 1026 $_ = <STDIN>; 1027 # Fail if not answered 1028 if (!defined $_) { 1029 print STDERR "\nArhh.. you are not here. I had better drop it right now.\n"; 1030 $self->{"override"} = OVERRIDE_FAIL; 1031 last; 1032 } 1033 chomp; 1034 # Overwrite 1035 if (lc $_ eq "o" || lc $_ eq "overwrite") { 1036 $self->{"override"} = OVERRIDE_OVERWRITE; 1037 # Append 1038 } elsif (lc $_ eq "a" || lc $_ eq "append") { 1039 $self->{"override"} = OVERRIDE_APPEND; 1040 # Ignore 1041 } elsif (lc $_ eq "i" || lc $_ eq "ignore") { 1042 $self->{"override"} = OVERRIDE_IGNORE; 1043 # Fail 1044 } elsif (lc $_ eq "f" || lc $_ eq "fail" || lc $_ eq "") { 1045 $self->{"override"} = OVERRIDE_FAIL; 1046 # Else, ask again 1047 } else { 1048 print STDERR "What?\n"; 1049 $self->{"override"} = OVERRIDE_ASK; 1050 } 1051 } 1052 # Overwrite or append 1053 if ( $self->{"override"} eq OVERRIDE_OVERWRITE 1054 || $self->{"override"} eq OVERRIDE_APPEND) { 1055 # OK 1056 } elsif ($self->{"override"} eq OVERRIDE_IGNORE) { 1057 $self->{"ignore"} = 1; 1058 } elsif ($self->{"override"} eq OVERRIDE_FAIL) { 1059 die "$THIS_FILE: $file: Output file exists\n"; 1060 } 1061 1062 # Not exists - we always create it 1063 } else { 1064 $self->{"override"} = OVERRIDE_OVERWRITE; 1065 } 1066 # The temporary log record backet 1067 if (!$self->{"ignore"}) { 1068 print STDERR "\n" if $VERBOSE > 2 && defined $START; 1069 print STDERR " Creating buffer for $month ... " 1070 if $VERBOSE > 2; 1071 $FH = tempfile or die "$THIS_FILE: tempfile: $!"; 1072 flock $FH, LOCK_EX or die "$THIS_FILE: tempfile: $!"; 1073 $self->{"FH"} = $FH; 1074 print STDERR "done\n" if $VERBOSE > 2; 1075 } 1076 $self->{"sizeorig"} = 0; 1077 return $self; 1078} 1079 1080# add: Add a record to the temporarily archive file 1081sub add : method { 1082 local ($_, %_); 1083 my ($self, $FH); 1084 ($self, $_) = @_; 1085 $FH = $self->{"FH"}; 1086 print $FH $_ or die "$THIS_FILE: tempfile: $!"; 1087 $self->{"sizeorig"} += length $_; 1088 return; 1089} 1090 1091# sort: Sort the records 1092sub sort : method { 1093 local ($_, %_); 1094 my ($self, $FH0, $FH1, $month, $count, $pos, $t, @recs); 1095 $self = $_[0]; 1096 ($FH0, $month) = ($self->{"FH"}, $self->{"month"}); 1097 1098 print STDERR "Sorting records of $month ... " if $VERBOSE > 1; 1099 print STDERR "\n" if $VERBOSE > 2; 1100 1101 # Obtain the information of each record 1102 print STDERR " Obtain the time and position of the records ... " 1103 if $VERBOSE > 2; 1104 seek $FH0, 0, SEEK_SET or die "$THIS_FILE: tempfile: $!"; 1105 @recs = qw(); 1106 ($pos = tell $FH0) != -1 or die "$THIS_FILE: tempfile: $!"; 1107 $count = 0; 1108 while (defined($_ = <$FH0>)) { 1109 $t = str2time($self->{"format"}->match($_)); 1110 push @recs, { "pos" => $pos, "time" => $t }; 1111 $count++; 1112 ($pos = tell $FH0) != -1 or die "$THIS_FILE: tempfile: $!"; 1113 } 1114 print STDERR "$count records\n" if $VERBOSE > 2; 1115 1116 # Sort by time and then original order 1117 print STDERR " Sorting the records by time ... " if $VERBOSE > 2; 1118 @recs = CORE::sort { $$a{"time"} <=> $$b{"time"} 1119 || $$a{"pos"} <=> $$b{"pos"} } @recs; 1120 print STDERR "done\n" if $VERBOSE > 2; 1121 1122 # Store the records according to the new order 1123 print STDERR " Creating new buffer for $month ... " if $VERBOSE > 2; 1124 $FH1 = tempfile or die "$THIS_FILE: tempfile: $!"; 1125 flock $FH1, LOCK_EX or die "$THIS_FILE: tempfile: $!"; 1126 print STDERR "done\n" if $VERBOSE > 2; 1127 print STDERR " Storing sorted records to the new buffer ... " 1128 if $VERBOSE > 2; 1129 $count = 0; 1130 foreach my $r (@recs) { 1131 seek $FH0, $$r{"pos"}, SEEK_SET or die "$THIS_FILE: tempfile: $!"; 1132 $_ = <$FH0>; 1133 print $FH1 $_ or die "$THIS_FILE: tempfile: $!"; 1134 $count++; 1135 } 1136 print STDERR "$count records\n" if $VERBOSE > 2; 1137 1138 # Use the new buffer instead of the old one 1139 print STDERR " Switching to the new buffer ... " if $VERBOSE > 2; 1140 flock $FH0, LOCK_UN or die "$THIS_FILE: tempfile: $!"; 1141 close $FH0 or die "$THIS_FILE: tempfile: $!"; 1142 $self->{"FH"} = $FH1; 1143 print STDERR "done\n" if $VERBOSE > 2; 1144 1145 print STDERR "$count records\n" if $VERBOSE > 1; 1146 return; 1147} 1148 1149# store_archive: Store the archived log records 1150sub store_archive : method { 1151 local ($_, %_); 1152 my ($self, $FH, $file, $count); 1153 $self = $_[0]; 1154 ($FH, $file) = ($self->{"FH"}, $self->{"file"}); 1155 # Reset the file reader 1156 seek $FH, 0, SEEK_SET or die "$THIS_FILE: tempfile: $!"; 1157 # Overwrite 1158 if ($self->{"override"} eq OVERRIDE_OVERWRITE) { 1159 print STDERR "Outputing to $file ... " if $VERBOSE > 1; 1160 print STDERR "\n" if $VERBOSE > 2; 1161 $self->{"io"}->open_write($file); 1162 # Append 1163 } elsif ($self->{"override"} eq OVERRIDE_APPEND) { 1164 print STDERR "Appending to $file ... " if $VERBOSE > 1; 1165 print STDERR "\n" if $VERBOSE > 2; 1166 $self->{"sizecomp"} = (stat $file)[7]; 1167 $self->{"io"}->open_append($file); 1168 } 1169 # Copy the data to the archive file 1170 print STDERR " Outputing records ... " if $VERBOSE > 2; 1171 $count = 0; 1172 while (defined($_ = <$FH>)) { 1173 $self->{"io"}->write($_); 1174 $count++; 1175 } 1176 print STDERR "$count records\n" if $VERBOSE > 2; 1177 $self->{"io"}->close; 1178 print STDERR "$count records\n" if $VERBOSE > 1; 1179 # Report the statistics 1180 # Overwrite 1181 if ($self->{"override"} eq OVERRIDE_OVERWRITE) { 1182 $self->{"sizecomp"} = (stat $file)[7]; 1183 printf STDERR "%s: writing %s records, %s bytes, %s bytes, %0.2f%%\n", 1184 $self->{"month"}, format_number($count), 1185 format_number($self->{"sizeorig"}), 1186 format_number($self->{"sizecomp"}), 1187 ($self->{"sizecomp"}*100/$self->{"sizeorig"}) 1188 if $VERBOSE > 0; 1189 1190 # Append 1191 } elsif ($self->{"override"} eq OVERRIDE_APPEND) { 1192 $self->{"sizecomp"} = (stat $file)[7] - $self->{"sizecomp"}; 1193 printf STDERR "%s: adding %s records, %s bytes, %s bytes, %0.2f%%\n", 1194 $self->{"month"}, format_number($count), 1195 format_number($self->{"sizeorig"}), 1196 format_number($self->{"sizecomp"}), 1197 ($self->{"sizecomp"}*100/$self->{"sizeorig"}) 1198 if $VERBOSE > 0; 1199 } 1200 return; 1201} 1202 1203# _private::IO: The abstract I/O handler interface 1204package _private::IO; 1205use 5.008; 1206use strict; 1207use warnings; 1208BEGIN { 1209import main; 1210} 1211 1212use Fcntl qw(:seek); 1213 1214use vars qw($GZIP_IO $BZIP2_IO); 1215undef $GZIP_IO; 1216undef $BZIP2_IO; 1217 1218# new: Initialize the I/O handler interface 1219sub new : method { bless {}, $_[0]; } 1220 1221# suffix: The file name suffix of this mime type 1222sub suffix : method { ""; } 1223 1224# check_gzip: Check for compression method of gzip 1225sub check_gzip : method { 1226 local ($_, %_); 1227 1228 # Checked before 1229 return ref($GZIP_IO)->new if defined $GZIP_IO; 1230 1231 # See whether Compress::Zlib or gzip 1232 print STDERR "Checking gzip I/O handler to use ... " if $VERBOSE > 1; 1233 print STDERR "\n Checking Compress::Zlib ... " if $VERBOSE > 2; 1234 # Check if we have Compress::Zlib 1235 if (eval { require Compress::Zlib; 1; }) { 1236 print STDERR "OK\nfound " if $VERBOSE > 2; 1237 print STDERR "Compress::Zlib\n" if $VERBOSE > 1; 1238 return ($GZIP_IO = _private::IO::Gzip::PM->new); 1239 } 1240 # Not found 1241 print STDERR "no\n" if $VERBOSE > 2; 1242 # It's OK not to warn 1243 1244 # Looking for gzip from PATH 1245 print STDERR " Checking gzip... " if $VERBOSE > 2; 1246 # Found in PATH 1247 if (defined($_ = whereis "gzip")) { 1248 print STDERR "$_\nfound " if $VERBOSE > 2; 1249 print STDERR "$_\n" if $VERBOSE > 1; 1250 return ($GZIP_IO = _private::IO::Gzip::Exec->new); 1251 } 1252 # Not found 1253 print STDERR "no\n" if $VERBOSE > 2; 1254 1255 print STDERR "not found\n" if $VERBOSE > 1; 1256 die "$THIS_FILE: Necessary Compress::Zlib or gzip not available.\n$SHORTHELP\n"; 1257} 1258 1259# check_bzip2: Check for compression method of bzip2 1260sub check_bzip2 : method { 1261 local ($_, %_); 1262 1263 # Checked before 1264 return ref($BZIP2_IO)->new if defined $BZIP2_IO; 1265 1266 # See whether Compress::Bzip2 or bzip2 1267 print STDERR "Checking bzip2 I/O handler to use ... " if $VERBOSE > 1; 1268 print STDERR "\n Checking Compress::Bzip2 ... " if $VERBOSE > 2; 1269 # Check if we have Compress::Bzip2 1270 if (eval { require Compress::Bzip2; import Compress::Bzip2 2.00; 1; }) { 1271 print STDERR "OK\nfound " if $VERBOSE > 2; 1272 print STDERR "Compress::Bzip2\n" if $VERBOSE > 1; 1273 return ($BZIP2_IO = _private::IO::Bzip2::PM->new); 1274 } 1275 # Not found 1276 print STDERR "no\n" if $VERBOSE > 2; 1277 # It's OK not to warn 1278 1279 # Looking for bzip2 from PATH 1280 print STDERR " Checking bzip2... " if $VERBOSE > 2; 1281 # Found in PATH 1282 if (defined($_ = whereis "bzip2")) { 1283 print STDERR "$_\nfound " if $VERBOSE > 2; 1284 print STDERR "$_\n" if $VERBOSE > 1; 1285 return ($BZIP2_IO = _private::IO::Bzip2::Exec->new); 1286 } 1287 # Not found 1288 print STDERR "no\n" if $VERBOSE > 2; 1289 1290 print STDERR "not found\n" if $VERBOSE > 1; 1291 die "$THIS_FILE: Necessary Compress::Bzip2 or bzip2 not available.\n$SHORTHELP\n"; 1292} 1293 1294# prepend_records: Prepend records to an existing file 1295# * static method * 1296# For most I/O we read records out and write back with 2 I/O accesses. 1297# But for plain text we need only open the file once. 1298# This implementation is for most I/O. Plain text implement this itself. 1299sub prepend_records : method { 1300 local ($_, %_); 1301 my ($class, $file, $FHT, $io, $count); 1302 ($class, $file, $FHT) = @_; 1303 1304 # Read the current records (added after program execution) 1305 $io = $class->new; 1306 print STDERR "Reading new records from $file ... " if $VERBOSE > 1; 1307 print STDERR "\n" if $VERBOSE > 2; 1308 $io->open_read($file); 1309 print STDERR " Reading new records ... " if $VERBOSE > 2; 1310 $count = 0; 1311 while (defined($_ = $io->readline)) { 1312 print $FHT $_ or die "$THIS_FILE: tempfile: $!"; 1313 $count++; 1314 } 1315 print STDERR "$count records\n" if $VERBOSE > 2; 1316 $io->close; 1317 print STDERR "$count records\n" if $VERBOSE > 1; 1318 1319 # Returing all the records 1320 # Start a new I/O handler of the same class 1321 seek $FHT, 0, SEEK_SET or die "$THIS_FILE: tempfile: $!"; 1322 $io = $class->new; 1323 print STDERR "Returning all records to $file ... " if $VERBOSE > 1; 1324 print STDERR "\n" if $VERBOSE > 2; 1325 $io->open_write($file); 1326 print STDERR " Outputing records ... " if $VERBOSE > 2; 1327 $count = 0; 1328 while (defined($_ = <$FHT>)) { 1329 $io->write($_); 1330 $count++; 1331 } 1332 print STDERR "$count records\n" if $VERBOSE > 2; 1333 $io->close; 1334 print STDERR "$count records\n" if $VERBOSE > 1; 1335 1336 return; 1337} 1338 1339 1340# _private::IO::Plain: The plain I/O handler 1341package _private::IO::Plain; 1342use 5.008; 1343use strict; 1344use warnings; 1345use base qw(_private::IO); 1346BEGIN { 1347import main; 1348} 1349 1350use Fcntl qw(:flock :seek); 1351 1352# open_read: Open the file for reading 1353sub open_read : method { 1354 local ($_, %_); 1355 my ($self, $file, $FH); 1356 ($self, $file, $FH) = @_; 1357 # Open the file if it is not opened yet 1358 if (!defined $FH) { 1359 print STDERR " Opening file in read mode ... " if $VERBOSE > 2; 1360 open $FH, "+<", $file or die "$THIS_FILE: $file: $!"; 1361 flock $FH, LOCK_EX; 1362 print STDERR "done\n" if $VERBOSE > 2; 1363 } 1364 ($self->{"file"}, $self->{"FH"}) = ($file, $FH); 1365 return; 1366} 1367 1368# open_write: Open the file for writing 1369sub open_write : method { 1370 local ($_, %_); 1371 my ($self, $file, $FH); 1372 ($self, $file, $FH) = @_; 1373 # Open the file if it is not opened yet 1374 if (!defined $FH) { 1375 print STDERR " Creating file in write mode ... " if $VERBOSE > 2; 1376 open $FH, "+>", $file or die "$THIS_FILE: $file: $!"; 1377 flock $FH, LOCK_EX; 1378 print STDERR "done\n" if $VERBOSE > 2; 1379 } 1380 ($self->{"file"}, $self->{"FH"}) = ($file, $FH); 1381 return; 1382} 1383 1384# open_append: Open the file for appending 1385sub open_append : method { 1386 local ($_, %_); 1387 my ($self, $file, $FH); 1388 ($self, $file, $FH) = @_; 1389 # Open the file if it is not opened yet 1390 if (!defined $FH) { 1391 print STDERR " Opening file in append mode ... " if $VERBOSE > 2; 1392 open $FH, ">>", $file or die "$THIS_FILE: $file: $!"; 1393 flock $FH, LOCK_EX; 1394 print STDERR "done\n" if $VERBOSE > 2; 1395 } 1396 ($self->{"file"}, $self->{"FH"}) = ($file, $FH); 1397 return; 1398} 1399 1400# readline: Read a line from the I/O stream 1401sub readline : method { 1402 local ($_, %_); 1403 my ($self, $FH); 1404 $self = $_[0]; 1405 $FH = $self->{"FH"}; 1406 return <$FH>; 1407} 1408 1409# write: Output data to the I/O stream 1410sub write : method { 1411 local ($_, %_); 1412 my ($self, $file, $FH); 1413 ($self, $_) = @_; 1414 ($file, $FH) = ($self->{"file"}, $self->{"FH"}); 1415 print $FH $_ or die "$THIS_FILE: $file: $!"; 1416 return; 1417} 1418 1419# close: Close the I/O stream 1420sub close : method { 1421 local ($_, %_); 1422 my ($self, $keep, $tmp, $file, $FH); 1423 ($self, $keep, $tmp) = @_; 1424 $keep = KEEP_ALL if @_ < 2; 1425 ($file, $FH) = ($self->{"file"}, $self->{"FH"}); 1426 1427 # Restart the file 1428 if ($keep eq KEEP_RESTART || $keep eq KEEP_THISMONTH) { 1429 # Empty the source file 1430 print STDERR " Emptying file ... " if $VERBOSE > 2; 1431 seek $FH, 0, SEEK_SET or die "$THIS_FILE: $file: $!"; 1432 truncate $FH, 0 or die "$THIS_FILE: $file: $!"; 1433 print STDERR "done\n" if $VERBOSE > 2; 1434 } 1435 1436 CORE::close $FH or die "$THIS_FILE: $file: $!"; 1437 delete $self->{"FH"}; 1438 delete $self->{"file"}; 1439 1440 # Delete the file 1441 if ($keep eq KEEP_DELETE) { 1442 print STDERR " Deleting file ... " if $VERBOSE > 2; 1443 unlink $file or die "$THIS_FILE: $file: $!"; 1444 print STDERR "done\n" if $VERBOSE > 2; 1445 } 1446 # Delete the temporary file if needed 1447 if (defined $tmp && -e $tmp) { 1448 unlink $tmp or die "$THIS_FILE: $tmp: $!"; 1449 } 1450 return; 1451} 1452 1453# prepend_records: Prepend records to an existing file 1454# * static method * 1455# Plain text version that only open the file once 1456sub prepend_records : method { 1457 local ($_, %_); 1458 my ($class, $file, $FHT, $FHC, $count); 1459 ($class, $file, $FHT) = @_; 1460 1461 # Read the current records (added after program execution) 1462 print STDERR "Reading new records from $file ... " if $VERBOSE > 1; 1463 print STDERR "\n" if $VERBOSE > 2; 1464 1465 print STDERR " Opening file in read/write mode ... " if $VERBOSE > 2; 1466 open $FHC, "+<", $file or die "$THIS_FILE: $file: $!"; 1467 flock $FHC, LOCK_EX; 1468 print STDERR "done\n" if $VERBOSE > 2; 1469 1470 # Read the new records 1471 print STDERR " Reading new records ... " if $VERBOSE > 2; 1472 $count = 0; 1473 while (defined($_ = <$FHC>)) { 1474 print $FHT $_ or die "$THIS_FILE: tempfile: $!"; 1475 $count++; 1476 } 1477 print STDERR "$count records\n" if $VERBOSE > 2; 1478 1479 # Reset the reader/writer 1480 seek $FHT, 0, SEEK_SET or die "$THIS_FILE: tempfile: $!"; 1481 seek $FHC, 0, SEEK_SET or die "$THIS_FILE: $file: $!"; 1482 truncate $FHC, 0 or die "$THIS_FILE: $file: $!"; 1483 1484 # Return all the records 1485 print STDERR " Outputing records ... " if $VERBOSE > 2; 1486 $count = 0; 1487 while (defined($_ = <$FHT>)) { 1488 print $FHC $_ or die "$THIS_FILE: $file: $!"; 1489 $count++; 1490 } 1491 print STDERR "$count records\n" if $VERBOSE > 2; 1492 1493 CORE::close $FHC or die "$THIS_FILE: $file: $!"; 1494 print STDERR "$count records\n" if $VERBOSE > 1; 1495 1496 return; 1497} 1498 1499 1500# _private::IO::Gzip::PM: The gzip module compression I/O handler 1501package _private::IO::Gzip::PM; 1502use 5.008; 1503use strict; 1504use warnings; 1505use base qw(_private::IO); 1506BEGIN { 1507import main; 1508} 1509 1510use Fcntl qw(:flock :seek); 1511use File::Temp qw(tempfile); 1512 1513# suffix: The file name suffix of this mime type 1514sub suffix : method { ".gz"; } 1515 1516# open_read: Open the file for reading 1517sub open_read : method { 1518 local ($_, %_); 1519 my ($self, $file, $FH); 1520 ($self, $file, $FH) = @_; 1521 # Open the file if it is not opened yet 1522 if (!defined $FH) { 1523 print STDERR " Opening file in read mode ... " if $VERBOSE > 2; 1524 open $FH, "+<", $file or die "$THIS_FILE: $file: $!"; 1525 binmode $FH or die "$THIS_FILE: $file: $!"; 1526 flock $FH, LOCK_EX; 1527 print STDERR "done\n" if $VERBOSE > 2; 1528 } 1529 ($self->{"file"}, $self->{"FH"}) = ($file, $FH); 1530 import Compress::Zlib qw(gzopen); 1531 print STDERR " Attaching file with gzopen(..., \"rb\") ... " if $VERBOSE > 2; 1532 $self->{"gz"} = gzopen($FH, "rb") or die "$THIS_FILE: $file: $!"; 1533 print STDERR "done\n" if $VERBOSE > 2; 1534 return; 1535} 1536 1537# open_write: Open the file for writing 1538sub open_write : method { 1539 local ($_, %_); 1540 my ($self, $file, $FH); 1541 ($self, $file, $FH) = @_; 1542 # Open the file if it is not opened yet 1543 if (!defined $FH) { 1544 print STDERR " Creating file in write mode ... " if $VERBOSE > 2; 1545 open $FH, "+>", $file or die "$THIS_FILE: $file: $!"; 1546 binmode $FH or die "$THIS_FILE: $file: $!"; 1547 flock $FH, LOCK_EX; 1548 print STDERR "done\n" if $VERBOSE > 2; 1549 } 1550 ($self->{"file"}, $self->{"FH"}) = ($file, $FH); 1551 import Compress::Zlib qw(gzopen); 1552 print STDERR " Attaching file with gzopen(..., \"wb9\") ... " if $VERBOSE > 2; 1553 $self->{"gz"} = gzopen($FH, "wb9") or die "$THIS_FILE: $file: $!"; 1554 print STDERR "done\n" if $VERBOSE > 2; 1555 return; 1556} 1557 1558# open_append: Open the file for appending 1559sub open_append : method { 1560 local ($_, %_); 1561 my ($self, $file, $FH, $gz); 1562 ($self, $file, $FH) = @_; 1563 # Open the file if it is not opened yet 1564 if (!defined $FH) { 1565 print STDERR " Opening file in read/write mode ... " if $VERBOSE > 2; 1566 open $FH, "+<", $file or die "$THIS_FILE: $file: $!"; 1567 binmode $FH or die "$THIS_FILE: $file: $!"; 1568 flock $FH, LOCK_EX; 1569 print STDERR "done\n" if $VERBOSE > 2; 1570 } 1571 ($self->{"file"}, $self->{"FH"}) = ($file, $FH); 1572 import Compress::Zlib qw(gzopen); 1573 1574 # Save the original data if file has content so that file size is 1575 # greater than 0. STDOUT is always of size 0. 1576 if ((stat $FH)[7] > 0) { 1577 my ($count, $FHT, $gzt, $n); 1578 seek $FH, 0, SEEK_SET or die "$THIS_FILE: $file: $!"; 1579 # Copy the original content to a buffer 1580 print STDERR " Reading compressed data to the buffer ... " if $VERBOSE > 2; 1581 $FHT = tempfile or die "$THIS_FILE: tempfile: $!"; 1582 while (defined($_ = <$FH>)) { 1583 print $FHT $_ or die "$THIS_FILE: tempfile: $!"; 1584 } 1585 print STDERR "done\n" if $VERBOSE > 2; 1586 print STDERR " Restarting file ... " if $VERBOSE > 2; 1587 seek $FHT, 0, SEEK_SET or die "$THIS_FILE: tempfile: $!"; 1588 seek $FH, 0, SEEK_SET or die "$THIS_FILE: $file: $!"; 1589 truncate $FH, 0 or die "$THIS_FILE: $file: $!"; 1590 print STDERR "done\n" if $VERBOSE > 2; 1591 1592 # Decompress the buffer and save to our file 1593 print STDERR " Attaching buffer with gzopen(..., \"rb\") ... " if $VERBOSE > 2; 1594 $gzt = gzopen($FHT, "rb") or die "$THIS_FILE: tempfile: $!"; 1595 print STDERR "done\n" if $VERBOSE > 2; 1596 print STDERR " Attaching file with gzopen(..., \"wb9\") ... " if $VERBOSE > 2; 1597 $gz = gzopen($FH, "wb9") or die "$THIS_FILE: $file: $!"; 1598 print STDERR "done\n" if $VERBOSE > 2; 1599 1600 print STDERR " Reading old records back from the buffer ... " if $VERBOSE > 2; 1601 $count = 0; 1602 while (($n = $gzt->gzreadline($_)) != 0) { 1603 die "$THIS_FILE: tempfile: " . $gz->gzerror if $n == -1; 1604 ($gz->gzwrite($_) == $n) or die "$THIS_FILE: $file: " . $gz->gzerror; 1605 $count++; 1606 } 1607 close $FHT or die "$THIS_FILE: tempfile: $!"; 1608 print STDERR "$count records\n" if $VERBOSE > 2; 1609 1610 # A whole new file 1611 } else { 1612 print STDERR " Attaching file with gzopen(..., \"wb9\") ... " if $VERBOSE > 2; 1613 $gz = gzopen($FH, "wb9") or die "$THIS_FILE: $file: $!"; 1614 print STDERR "done\n" if $VERBOSE > 2; 1615 } 1616 1617 $self->{"gz"} = $gz; 1618 return; 1619} 1620 1621# readline: Read a line from the I/O stream 1622sub readline : method { 1623 local ($_, %_); 1624 my ($self, $file, $gz, $n); 1625 $self = $_[0]; 1626 ($file, $gz) = ($self->{"file"}, $self->{"gz"}); 1627 (($n = $gz->gzreadline($_)) != -1) or die "$THIS_FILE: $file: " . $gz->gzerror; 1628 return undef if $n == 0; 1629 return $_; 1630} 1631 1632# write: Output data to the I/O stream 1633sub write : method { 1634 local ($_, %_); 1635 my ($self, $file, $gz); 1636 ($self, $_) = @_; 1637 ($file, $gz) = ($self->{"file"}, $self->{"gz"}); 1638 ($gz->gzwrite($_) == length $_) or die "$THIS_FILE: $file: " . $gz->gzerror; 1639 return; 1640} 1641 1642# close: Close the I/O stream 1643sub close : method { 1644 local ($_, %_); 1645 my ($self, $keep, $tmp, $file, $FH, $gz); 1646 ($self, $keep, $tmp) = @_; 1647 $keep = KEEP_ALL if @_ < 2; 1648 ($file, $FH, $gz) = ($self->{"file"}, $self->{"FH"}, $self->{"gz"}); 1649 1650 # Restart the file 1651 if ($keep eq KEEP_RESTART || $keep eq KEEP_THISMONTH) { 1652 # Empty the source file 1653 print STDERR " Emptying file ... " if $VERBOSE > 2; 1654 seek $FH, 0, SEEK_SET or die "$THIS_FILE: $file: $!"; 1655 truncate $FH, 0 or die "$THIS_FILE: $file: $!"; 1656 print STDERR "done\n" if $VERBOSE > 2; 1657 1658 # Create empty compressed content 1659 print STDERR " Applying empty compressed content ... " if $VERBOSE > 2; 1660 $_ = gzopen($FH, "wb9") or die "$THIS_FILE: $file: $!"; 1661 $_->gzclose and die "$THIS_FILE: $file: " . $_->gzerror; 1662 undef $_; 1663 undef $gz; 1664 print STDERR "done\n" if $VERBOSE > 2; 1665 } 1666 1667 if (defined $gz) { 1668 $gz->gzclose and die "$THIS_FILE: $file: " . $gz->gzerror; 1669 } 1670 CORE::close $self->{"FH"} if $self->{"FH"}->opened; 1671 delete $self->{"gz"}; 1672 delete $self->{"FH"}; 1673 delete $self->{"file"}; 1674 1675 # Delete the file 1676 if ($keep eq KEEP_DELETE) { 1677 print STDERR " Deleting file ... " if $VERBOSE > 2; 1678 unlink $file or die "$THIS_FILE: $file: $!"; 1679 print STDERR "done\n" if $VERBOSE > 2; 1680 } 1681 # Delete the temporary file if needed 1682 if (defined $tmp && -e $tmp) { 1683 unlink $tmp or die "$THIS_FILE: $tmp: $!"; 1684 } 1685 return; 1686} 1687 1688 1689# _private::IO::Gzip::Exec: The gzip executable compression I/O handler 1690package _private::IO::Gzip::Exec; 1691use 5.008; 1692use strict; 1693use warnings; 1694use base qw(_private::IO); 1695BEGIN { 1696import main; 1697} 1698 1699use Fcntl qw(:flock :seek); 1700use File::Temp qw(tempfile); 1701 1702use vars qw($EXEC); 1703 1704# suffix: The file name suffix of this mime type 1705sub suffix : method { ".gz"; } 1706 1707# open_read: Open the file for reading 1708sub open_read : method { 1709 local ($_, %_); 1710 my ($self, $file, $FH, $PH, $CMD); 1711 ($self, $file, $FH) = @_; 1712 # Open the file if it is not opened yet 1713 if (!defined $FH) { 1714 print STDERR " Opening file in read mode ... " if $VERBOSE > 2; 1715 open $FH, "+<", $file or die "$THIS_FILE: $file: $!"; 1716 binmode $FH or die "$THIS_FILE: $file: $!"; 1717 print STDERR "done\n" if $VERBOSE > 2; 1718 } else { 1719 flock $FH, LOCK_UN; 1720 } 1721 ($self->{"file"}, $self->{"FH"}) = ($file, $FH); 1722 $EXEC = whereis "gzip" if !defined $EXEC; 1723 1724 @_ = ($EXEC, "-cdf"); 1725 @_ = map "\"$_\"", @_ if $^O eq "MSWin32"; 1726 $CMD = join " ", @_; 1727 print STDERR " Starting $CMD from file ... " if $VERBOSE > 2; 1728 # Redirect STDIN to $FH 1729 open STDIN, "<&", $FH or die "$THIS_FILE: $file: $!"; 1730 # Start the process 1731 if ($^O eq "MSWin32") { 1732 open $PH, "$CMD |" or die "$THIS_FILE: $CMD: $!"; 1733 } else { 1734 open $PH, "-|", @_ or die "$THIS_FILE: $CMD: $!"; 1735 } 1736 # Restore STDIN 1737 open STDIN, "<&", $STDIN or die "$THIS_FILE: STDIN: $!"; 1738 print STDERR "done\n" if $VERBOSE > 2; 1739 ($self->{"CMD"}, $self->{"PH"}) = ([@_], $PH); 1740 return; 1741} 1742 1743# open_write: Open the file for writing 1744sub open_write : method { 1745 local ($_, %_); 1746 my ($self, $file, $FH, $PH, $CMD); 1747 ($self, $file, $FH) = @_; 1748 # Open the file if it is not opened yet 1749 if (!defined $FH) { 1750 print STDERR " Creating file in write mode ... " if $VERBOSE > 2; 1751 open $FH, "+>", $file or die "$THIS_FILE: $file: $!"; 1752 binmode $FH or die "$THIS_FILE: $file: $!"; 1753 print STDERR "done\n" if $VERBOSE > 2; 1754 } else { 1755 flock $FH, LOCK_UN; 1756 } 1757 ($self->{"file"}, $self->{"FH"}) = ($file, $FH); 1758 $EXEC = whereis "gzip" if !defined $EXEC; 1759 1760 @_ = ($EXEC, "-c9f"); 1761 @_ = map "\"$_\"", @_ if $^O eq "MSWin32"; 1762 $CMD = join " ", @_; 1763 print STDERR " Starting $CMD to file ... " if $VERBOSE > 2; 1764 # Redirect STDOUT to $FH 1765 open STDOUT, ">&", $FH or die "$THIS_FILE: $file: $!"; 1766 # Start the process 1767 if ($^O eq "MSWin32") { 1768 open $PH, "| $CMD" or die "$THIS_FILE: $CMD: $!"; 1769 } else { 1770 open $PH, "|-", @_ or die "$THIS_FILE: $CMD: $!"; 1771 } 1772 # Restore STDOUT 1773 open STDOUT, ">&", $STDOUT or die "$THIS_FILE: STDOUT: $!"; 1774 print STDERR "done\n" if $VERBOSE > 2; 1775 ($self->{"CMD"}, $self->{"PH"}) = ([@_], $PH); 1776 return; 1777} 1778 1779# open_append: Open the file for appending 1780sub open_append : method { 1781 local ($_, %_); 1782 my ($self, $file, $FH, $PH, $CMD); 1783 ($self, $file, $FH) = @_; 1784 # Open the file if it is not opened yet 1785 if (!defined $FH) { 1786 print STDERR " Opening file in read/write mode ... " if $VERBOSE > 2; 1787 open $FH, "+<", $file or die "$THIS_FILE: $file: $!"; 1788 binmode $FH or die "$THIS_FILE: $file: $!"; 1789 print STDERR "done\n" if $VERBOSE > 2; 1790 } else { 1791 flock $FH, LOCK_UN; 1792 } 1793 ($self->{"file"}, $self->{"FH"}) = ($file, $FH); 1794 $EXEC = whereis "gzip" if !defined $EXEC; 1795 1796 # Save the original data if file has content so that file size is 1797 # greater than 0. STDOUT is always of size 0. 1798 if ((stat $FH)[7] > 0) { 1799 my ($count, $FHT, $PHT, $CMDT); 1800 seek $FH, 0, SEEK_SET or die "$THIS_FILE: $file: $!"; 1801 # Copy the original content to a buffer 1802 print STDERR " Reading compressed data to the buffer ... " if $VERBOSE > 2; 1803 $FHT = tempfile or die "$THIS_FILE: tempfile: $!"; 1804 while (defined($_ = <$FH>)) { 1805 print $FHT $_ or die "$THIS_FILE: tempfile: $!"; 1806 } 1807 print STDERR "done\n" if $VERBOSE > 2; 1808 print STDERR " Restarting file ... " if $VERBOSE > 2; 1809 seek $FHT, 0, SEEK_SET or die "$THIS_FILE: tempfile: $!"; 1810 seek $FH, 0, SEEK_SET or die "$THIS_FILE: $file: $!"; 1811 truncate $FH, 0 or die "$THIS_FILE: $file: $!"; 1812 print STDERR "done\n" if $VERBOSE > 2; 1813 1814 # Decompress the buffer and save to our file 1815 @_ = ($EXEC, "-cdf"); 1816 @_ = map "\"$_\"", @_ if $^O eq "MSWin32"; 1817 $CMDT = join " ", @_; 1818 print STDERR " Starting $CMDT from buffer ... " if $VERBOSE > 2; 1819 # Redirect STDIN to $FH 1820 open STDIN, "<&", $FHT or die "$THIS_FILE: tempfile: $!"; 1821 # Start the process 1822 if ($^O eq "MSWin32") { 1823 open $PHT, "$CMDT |" or die "$THIS_FILE: $CMDT: $!"; 1824 } else { 1825 open $PHT, "-|", @_ or die "$THIS_FILE: $CMDT: $!"; 1826 } 1827 # Restore STDIN 1828 open STDIN, "<&", $STDIN or die "$THIS_FILE: STDIN: $!"; 1829 print STDERR "done\n" if $VERBOSE > 2; 1830 1831 @_ = ($EXEC, "-c9f"); 1832 @_ = map "\"$_\"", @_ if $^O eq "MSWin32"; 1833 $CMD = join " ", @_; 1834 print STDERR " Starting $CMD to file ... " if $VERBOSE > 2; 1835 # Redirect STDOUT to $FH 1836 open STDOUT, ">&", $FH or die "$THIS_FILE: $file: $!"; 1837 # Start the process 1838 if ($^O eq "MSWin32") { 1839 open $PH, "| $CMD" or die "$THIS_FILE: $CMD: $!"; 1840 } else { 1841 open $PH, "|-", @_ or die "$THIS_FILE: $CMD: $!"; 1842 } 1843 # Restore STDOUT 1844 open STDOUT, ">&", $STDOUT or die "$THIS_FILE: STDOUT: $!"; 1845 print STDERR "done\n" if $VERBOSE > 2; 1846 1847 print STDERR " Reading old records back from the buffer ... " if $VERBOSE > 2; 1848 $count = 0; 1849 while (defined($_ = <$PHT>)) { 1850 print $PH $_ or die "$THIS_FILE: $file: $!"; 1851 $count++; 1852 } 1853 close $PHT or die "$THIS_FILE: $CMDT: $!"; 1854 close $FHT or die "$THIS_FILE: tempfile: $!"; 1855 print STDERR "$count records\n" if $VERBOSE > 2; 1856 1857 # A whole new file 1858 } else { 1859 @_ = ($EXEC, "-c9f"); 1860 @_ = map "\"$_\"", @_ if $^O eq "MSWin32"; 1861 $CMD = join " ", @_; 1862 print STDERR " Starting $CMD to file ... " if $VERBOSE > 2; 1863 # Redirect STDOUT to $FH 1864 open STDOUT, ">&", $FH or die "$THIS_FILE: $file: $!"; 1865 # Start the process 1866 if ($^O eq "MSWin32") { 1867 open $PH, "| $CMD" or die "$THIS_FILE: $CMD: $!"; 1868 } else { 1869 open $PH, "|-", @_ or die "$THIS_FILE: $CMD: $!"; 1870 } 1871 # Restore STDOUT 1872 open STDOUT, ">&", $STDOUT or die "$THIS_FILE: STDOUT: $!"; 1873 print STDERR "done\n" if $VERBOSE > 2; 1874 } 1875 1876 ($self->{"CMD"}, $self->{"PH"}) = ([@_], $PH); 1877 return; 1878} 1879 1880# readline: Read a line from the I/O stream 1881sub readline : method { 1882 local ($_, %_); 1883 my ($self, $PH); 1884 $self = $_[0]; 1885 $PH = $self->{"PH"}; 1886 return <$PH>; 1887} 1888 1889# write: Output data to the I/O stream 1890sub write : method { 1891 local ($_, %_); 1892 my ($self, $CMD, $PH); 1893 ($self, $_) = @_; 1894 ($CMD, $PH) = (join(" ", @{$self->{"CMD"}}), $self->{"PH"}); 1895 print $PH $_ or die "$THIS_FILE: $CMD: $!"; 1896 return; 1897} 1898 1899# close: Close the I/O stream 1900sub close : method { 1901 local ($_, %_); 1902 my ($self, $keep, $tmp, $file, $FH, $CMD, $PH); 1903 ($self, $keep, $tmp) = @_; 1904 $keep = KEEP_ALL if @_ < 2; 1905 ($file, $FH) = ($self->{"file"}, $self->{"FH"}); 1906 1907 # Restart the file 1908 if ($keep eq KEEP_RESTART || $keep eq KEEP_THISMONTH) { 1909 # Empty the source file 1910 print STDERR " Emptying file ... " if $VERBOSE > 2; 1911 seek $FH, 0, SEEK_SET or die "$THIS_FILE: $file: $!"; 1912 truncate $FH, 0 or die "$THIS_FILE: $file: $!"; 1913 print STDERR "done\n" if $VERBOSE > 2; 1914 1915 # Create empty compressed content 1916 print STDERR " Applying empty compressed content ... " if $VERBOSE > 2; 1917 $EXEC = whereis "gzip" if !defined $EXEC; 1918 @_ = ($EXEC, "-c9f"); 1919 @_ = map "\"$_\"", @_ if $^O eq "MSWin32"; 1920 $CMD = join " ", @_; 1921 # Redirect STDOUT to $FH 1922 open STDOUT, ">&", $FH or die "$THIS_FILE: $file: $!"; 1923 # Start the process and end it 1924 if ($^O eq "MSWin32") { 1925 open $PH, "| $CMD" or die "$THIS_FILE: $CMD: $!"; 1926 } else { 1927 open $PH, "|-", @_ or die "$THIS_FILE: $CMD: $!"; 1928 } 1929 close $PH or die "$THIS_FILE: $CMD: $!"; 1930 # Restore STDOUT 1931 open STDOUT, ">&", $STDOUT or die "$THIS_FILE: STDOUT: $!"; 1932 print STDERR "done\n" if $VERBOSE > 2; 1933 } 1934 1935 ($CMD, $PH) = (join(" ", @{$self->{"CMD"}}), $self->{"PH"}); 1936 CORE::close $PH or die "$THIS_FILE: $CMD: $!"; 1937 CORE::close $FH or die "$THIS_FILE: $file: $!"; 1938 delete $self->{"PH"}; 1939 delete $self->{"CMD"}; 1940 delete $self->{"FH"}; 1941 delete $self->{"file"}; 1942 1943 # Delete the file 1944 if ($keep eq KEEP_DELETE) { 1945 print STDERR " Deleting file ... " if $VERBOSE > 2; 1946 unlink $file or die "$THIS_FILE: $file: $!"; 1947 print STDERR "done\n" if $VERBOSE > 2; 1948 } 1949 # Delete the temporary file if needed 1950 if (defined $tmp && -e $tmp) { 1951 unlink $tmp or die "$THIS_FILE: $tmp: $!"; 1952 } 1953 return; 1954} 1955 1956 1957# _private::IO::Bzip2::PM: The bzip2 module compression I/O handler 1958package _private::IO::Bzip2::PM; 1959use 5.008; 1960use strict; 1961use warnings; 1962use base qw(_private::IO); 1963BEGIN { 1964import main; 1965} 1966 1967use Fcntl qw(:flock :seek); 1968use File::Temp qw(tempfile); 1969 1970# suffix: The file name suffix of this mime type 1971sub suffix : method { ".bz2"; } 1972 1973# open_read: Open the file for reading 1974sub open_read : method { 1975 local ($_, %_); 1976 my ($self, $file, $FH); 1977 ($self, $file, $FH) = @_; 1978 # Open the file if it is not opened yet 1979 if (!defined $FH) { 1980 print STDERR " Opening file in read mode ... " if $VERBOSE > 2; 1981 open $FH, "+<", $file or die "$THIS_FILE: $file: $!"; 1982 binmode $FH or die "$THIS_FILE: $file: $!"; 1983 flock $FH, LOCK_EX; 1984 print STDERR "done\n" if $VERBOSE > 2; 1985 } 1986 ($self->{"file"}, $self->{"FH"}) = ($file, $FH); 1987 import Compress::Bzip2 qw(bzopen); 1988 print STDERR " Attaching file with bzopen(..., \"rb\") ... " if $VERBOSE > 2; 1989 $self->{"bz"} = bzopen($FH, "rb") or die "$THIS_FILE: $file: $!"; 1990 print STDERR "done\n" if $VERBOSE > 2; 1991 return; 1992} 1993 1994# open_write: Open the file for writing 1995sub open_write : method { 1996 local ($_, %_); 1997 my ($self, $file, $FH); 1998 ($self, $file, $FH) = @_; 1999 # Open the file if it is not opened yet 2000 if (!defined $FH) { 2001 print STDERR " Creating file in write mode ... " if $VERBOSE > 2; 2002 open $FH, "+>", $file or die "$THIS_FILE: $file: $!"; 2003 binmode $FH or die "$THIS_FILE: $file: $!"; 2004 flock $FH, LOCK_EX; 2005 print STDERR "done\n" if $VERBOSE > 2; 2006 } 2007 ($self->{"file"}, $self->{"FH"}) = ($file, $FH); 2008 import Compress::Bzip2 qw(bzopen); 2009 print STDERR " Attaching file with bzopen(..., \"wb9\") ... " if $VERBOSE > 2; 2010 $self->{"bz"} = bzopen($FH, "wb9") or die "$THIS_FILE: $file: $!"; 2011 print STDERR "done\n" if $VERBOSE > 2; 2012 return; 2013} 2014 2015# open_append: Open the file for appending 2016sub open_append : method { 2017 local ($_, %_); 2018 my ($self, $file, $FH, $bz); 2019 ($self, $file, $FH) = @_; 2020 # Open the file if it is not opened yet 2021 if (!defined $FH) { 2022 print STDERR " Opening file in read/write mode ... " if $VERBOSE > 2; 2023 open $FH, "+<", $file or die "$THIS_FILE: $file: $!"; 2024 binmode $FH or die "$THIS_FILE: $file: $!"; 2025 flock $FH, LOCK_EX; 2026 print STDERR "done\n" if $VERBOSE > 2; 2027 } 2028 ($self->{"file"}, $self->{"FH"}) = ($file, $FH); 2029 import Compress::Bzip2 qw(bzopen); 2030 2031 # Save the original data if file has content so that file size is 2032 # greater than 0. STDOUT is always of size 0. 2033 if ((stat $FH)[7] > 0) { 2034 my ($count, $FHT, $bzt, $n); 2035 seek $FH, 0, SEEK_SET or die "$THIS_FILE: $file: $!"; 2036 # Copy the original content to a buffer 2037 print STDERR " Reading compressed data to the buffer ... " if $VERBOSE > 2; 2038 $FHT = tempfile or die "$THIS_FILE: tempfile: $!"; 2039 while (defined($_ = <$FH>)) { 2040 print $FHT $_ or die "$THIS_FILE: tempfile: $!"; 2041 } 2042 print STDERR "done\n" if $VERBOSE > 2; 2043 print STDERR " Restarting file ... " if $VERBOSE > 2; 2044 seek $FHT, 0, SEEK_SET or die "$THIS_FILE: tempfile: $!"; 2045 seek $FH, 0, SEEK_SET or die "$THIS_FILE: $file: $!"; 2046 truncate $FH, 0 or die "$THIS_FILE: $file: $!"; 2047 print STDERR "done\n" if $VERBOSE > 2; 2048 2049 # Decompress the buffer and save to our file 2050 print STDERR " Attaching buffer with bzopen(..., \"rb\") ... " if $VERBOSE > 2; 2051 $bzt = bzopen($FHT, "rb") or die "$THIS_FILE: tempfile: $!"; 2052 print STDERR "done\n" if $VERBOSE > 2; 2053 print STDERR " Attaching file with bzopen(..., \"wb9\") ... " if $VERBOSE > 2; 2054 $bz = bzopen($FH, "wb9") or die "$THIS_FILE: $file: $!"; 2055 print STDERR "done\n" if $VERBOSE > 2; 2056 2057 print STDERR " Reading old records back from the buffer ... " if $VERBOSE > 2; 2058 $count = 0; 2059 while (($n = $bzt->bzreadline($_)) != 0) { 2060 die "$THIS_FILE: tempfile: " . $bz->bzerror if $n == -1; 2061 ($bz->bzwrite($_, length $_) == length $_) 2062 or die "$THIS_FILE: $file: " . $bz->bzerror; 2063 $count++; 2064 } 2065 close $FHT or die "$THIS_FILE: tempfile: $!"; 2066 print STDERR "$count records\n" if $VERBOSE > 2; 2067 2068 # A whole new file 2069 } else { 2070 print STDERR " Attaching file with bzopen(..., \"wb9\") ... " if $VERBOSE > 2; 2071 $bz = bzopen($FH, "wb9") or die "$THIS_FILE: $file: $!"; 2072 print STDERR "done\n" if $VERBOSE > 2; 2073 } 2074 2075 $self->{"bz"} = $bz; 2076 return; 2077} 2078 2079# readline: Read a line from the I/O stream 2080sub readline : method { 2081 local ($_, %_); 2082 my ($self, $file, $bz, $n); 2083 $self = $_[0]; 2084 ($file, $bz) = ($self->{"file"}, $self->{"bz"}); 2085 (($n = $bz->bzreadline($_)) != -1) or die "$THIS_FILE: $file: " . $bz->bzerror; 2086 return undef if $n == 0; 2087 return $_; 2088} 2089 2090# write: Output data to the I/O stream 2091sub write : method { 2092 local ($_, %_); 2093 my ($self, $file, $bz); 2094 ($self, $_) = @_; 2095 ($file, $bz) = ($self->{"file"}, $self->{"bz"}); 2096 ($bz->bzwrite($_, length $_) == length $_) 2097 or die "$THIS_FILE: $file: " . $bz->bzerror; 2098 return; 2099} 2100 2101# close: Close the I/O stream 2102sub close : method { 2103 local ($_, %_); 2104 my ($self, $keep, $tmp, $file, $FH, $bz); 2105 ($self, $keep, $tmp) = @_; 2106 $keep = KEEP_ALL if @_ < 2; 2107 ($file, $FH, $bz) = ($self->{"file"}, $self->{"FH"}, $self->{"bz"}); 2108 2109 # Restart the file 2110 if ($keep eq KEEP_RESTART || $keep eq KEEP_THISMONTH) { 2111 # Empty the source file 2112 print STDERR " Emptying file ... " if $VERBOSE > 2; 2113 seek $FH, 0, SEEK_SET or die "$THIS_FILE: $file: $!"; 2114 truncate $FH, 0 or die "$THIS_FILE: $file: $!"; 2115 print STDERR "done\n" if $VERBOSE > 2; 2116 2117 # Create empty compressed content 2118 print STDERR " Applying empty compressed content ... " if $VERBOSE > 2; 2119 $_ = bzopen($FH, "wb9") or die "$THIS_FILE: $file: $!"; 2120 $_->bzclose and die "$THIS_FILE: $file: " . $_->bzerror; 2121 undef $_; 2122 undef $bz; 2123 print STDERR "done\n" if $VERBOSE > 2; 2124 } 2125 2126 if (defined $bz) { 2127 $bz->bzclose and die "$THIS_FILE: $file: " . $bz->bzerror; 2128 } 2129 CORE::close $self->{"FH"} if $self->{"FH"}->opened; 2130 delete $self->{"bz"}; 2131 delete $self->{"FH"}; 2132 delete $self->{"file"}; 2133 2134 # Delete the file 2135 if ($keep eq KEEP_DELETE) { 2136 print STDERR " Deleting file ... " if $VERBOSE > 2; 2137 unlink $file or die "$THIS_FILE: $file: $!"; 2138 print STDERR "done\n" if $VERBOSE > 2; 2139 } 2140 # Delete the temporary file if needed 2141 if (defined $tmp && -e $tmp) { 2142 unlink $tmp or die "$THIS_FILE: $tmp: $!"; 2143 } 2144 return; 2145} 2146 2147 2148# _private::IO::Bzip2::Exec: The bzip2 executable compression I/O handler 2149package _private::IO::Bzip2::Exec; 2150use 5.008; 2151use strict; 2152use warnings; 2153use base qw(_private::IO); 2154BEGIN { 2155import main; 2156} 2157 2158use Fcntl qw(:flock :seek); 2159use File::Temp qw(tempfile); 2160 2161use vars qw($EXEC); 2162 2163# suffix: The file name suffix of this mime type 2164sub suffix : method { ".bz2"; } 2165 2166# open_read: Open the file for reading 2167sub open_read : method { 2168 local ($_, %_); 2169 my ($self, $file, $FH, $PH, $CMD); 2170 ($self, $file, $FH) = @_; 2171 # Open the file if it is not opened yet 2172 if (!defined $FH) { 2173 print STDERR " Opening file in read mode ... " if $VERBOSE > 2; 2174 open $FH, "+<", $file or die "$THIS_FILE: $file: $!"; 2175 binmode $FH or die "$THIS_FILE: $file: $!"; 2176 print STDERR "done\n" if $VERBOSE > 2; 2177 } else { 2178 flock $FH, LOCK_UN; 2179 } 2180 ($self->{"file"}, $self->{"FH"}) = ($file, $FH); 2181 $EXEC = whereis "bzip2" if !defined $EXEC; 2182 2183 @_ = ($EXEC, "-cdf"); 2184 @_ = map "\"$_\"", @_ if $^O eq "MSWin32"; 2185 $CMD = join " ", @_; 2186 print STDERR " Starting $CMD from file ... " if $VERBOSE > 2; 2187 # Redirect STDIN to $FH 2188 open STDIN, "<&", $FH or die "$THIS_FILE: $file: $!"; 2189 # Start the process 2190 if ($^O eq "MSWin32") { 2191 open $PH, "$CMD |" or die "$THIS_FILE: $CMD: $!"; 2192 } else { 2193 open $PH, "-|", @_ or die "$THIS_FILE: $CMD: $!"; 2194 } 2195 # Restore STDIN 2196 open STDIN, "<&", $STDIN or die "$THIS_FILE: STDIN: $!"; 2197 print STDERR "done\n" if $VERBOSE > 2; 2198 ($self->{"CMD"}, $self->{"PH"}) = ([@_], $PH); 2199 return; 2200} 2201 2202# open_write: Open the file for writing 2203sub open_write : method { 2204 local ($_, %_); 2205 my ($self, $file, $FH, $PH, $CMD); 2206 ($self, $file, $FH) = @_; 2207 # Open the file if it is not opened yet 2208 if (!defined $FH) { 2209 print STDERR " Creating file in write mode ... " if $VERBOSE > 2; 2210 open $FH, "+>", $file or die "$THIS_FILE: $file: $!"; 2211 binmode $FH or die "$THIS_FILE: $file: $!"; 2212 print STDERR "done\n" if $VERBOSE > 2; 2213 } else { 2214 flock $FH, LOCK_UN; 2215 } 2216 ($self->{"file"}, $self->{"FH"}) = ($file, $FH); 2217 $EXEC = whereis "bzip2" if !defined $EXEC; 2218 2219 @_ = ($EXEC, "-9f"); 2220 @_ = map "\"$_\"", @_ if $^O eq "MSWin32"; 2221 $CMD = join " ", @_; 2222 print STDERR " Starting $CMD to file ... " if $VERBOSE > 2; 2223 # Redirect STDOUT to $FH 2224 open STDOUT, ">&", $FH or die "$THIS_FILE: $file: $!"; 2225 # Start the process 2226 if ($^O eq "MSWin32") { 2227 open $PH, "| $CMD" or die "$THIS_FILE: $CMD: $!"; 2228 } else { 2229 open $PH, "|-", @_ or die "$THIS_FILE: $CMD: $!"; 2230 } 2231 # Restore STDOUT 2232 open STDOUT, ">&", $STDOUT or die "$THIS_FILE: STDOUT: $!"; 2233 print STDERR "done\n" if $VERBOSE > 2; 2234 ($self->{"CMD"}, $self->{"PH"}) = ([@_], $PH); 2235 return; 2236} 2237 2238# open_append: Open the file for appending 2239sub open_append : method { 2240 local ($_, %_); 2241 my ($self, $file, $FH, $PH, $CMD); 2242 ($self, $file, $FH) = @_; 2243 # Open the file if it is not opened yet 2244 if (!defined $FH) { 2245 print STDERR " Opening file in read/write mode ... " if $VERBOSE > 2; 2246 open $FH, "+<", $file or die "$THIS_FILE: $file: $!"; 2247 binmode $FH or die "$THIS_FILE: $file: $!"; 2248 print STDERR "done\n" if $VERBOSE > 2; 2249 } else { 2250 flock $FH, LOCK_UN; 2251 } 2252 ($self->{"file"}, $self->{"FH"}) = ($file, $FH); 2253 $EXEC = whereis "bzip2" if !defined $EXEC; 2254 2255 # Save the original data if file has content so that file size is 2256 # greater than 0. STDOUT is always of size 0. 2257 if ((stat $FH)[7] > 0) { 2258 my ($count, $FHT, $PHT, $CMDT); 2259 seek $FH, 0, SEEK_SET or die "$THIS_FILE: $file: $!"; 2260 # Copy the original content to a buffer 2261 print STDERR " Reading compressed data to the buffer ... " if $VERBOSE > 2; 2262 $FHT = tempfile or die "$THIS_FILE: tempfile: $!"; 2263 while (defined($_ = <$FH>)) { 2264 print $FHT $_ or die "$THIS_FILE: tempfile: $!"; 2265 } 2266 print STDERR "done\n" if $VERBOSE > 2; 2267 print STDERR " Restarting file ... " if $VERBOSE > 2; 2268 seek $FHT, 0, SEEK_SET or die "$THIS_FILE: tempfile: $!"; 2269 seek $FH, 0, SEEK_SET or die "$THIS_FILE: $file: $!"; 2270 truncate $FH, 0 or die "$THIS_FILE: $file: $!"; 2271 print STDERR "done\n" if $VERBOSE > 2; 2272 2273 # Decompress the buffer and save to our file 2274 @_ = ($EXEC, "-cdf"); 2275 @_ = map "\"$_\"", @_ if $^O eq "MSWin32"; 2276 $CMDT = join " ", @_; 2277 print STDERR " Starting $CMDT from buffer ... " if $VERBOSE > 2; 2278 # Redirect STDIN to $FH 2279 open STDIN, "<&", $FHT or die "$THIS_FILE: tempfile: $!"; 2280 # Start the process 2281 if ($^O eq "MSWin32") { 2282 open $PHT, "$CMDT |" or die "$THIS_FILE: $CMDT: $!"; 2283 } else { 2284 open $PHT, "-|", @_ or die "$THIS_FILE: $CMDT: $!"; 2285 } 2286 # Restore STDIN 2287 open STDIN, "<&", $STDIN or die "$THIS_FILE: STDIN: $!"; 2288 print STDERR "done\n" if $VERBOSE > 2; 2289 2290 @_ = ($EXEC, "-9f"); 2291 @_ = map "\"$_\"", @_ if $^O eq "MSWin32"; 2292 $CMD = join " ", @_; 2293 print STDERR " Starting $CMD to file ... " if $VERBOSE > 2; 2294 # Redirect STDOUT to $FH 2295 open STDOUT, ">&", $FH or die "$THIS_FILE: $file: $!"; 2296 # Start the process 2297 if ($^O eq "MSWin32") { 2298 open $PH, "| $CMD" or die "$THIS_FILE: $CMD: $!"; 2299 } else { 2300 open $PH, "|-", @_ or die "$THIS_FILE: $CMD: $!"; 2301 } 2302 # Restore STDOUT 2303 open STDOUT, ">&", $STDOUT or die "$THIS_FILE: STDOUT: $!"; 2304 print STDERR "done\n" if $VERBOSE > 2; 2305 2306 print STDERR " Reading old records back from the buffer ... " if $VERBOSE > 2; 2307 $count = 0; 2308 while (defined($_ = <$PHT>)) { 2309 print $PH $_ or die "$THIS_FILE: $file: $!"; 2310 $count++; 2311 } 2312 close $PHT or die "$THIS_FILE: $CMDT: $!"; 2313 close $FHT or die "$THIS_FILE: tempfile: $!"; 2314 print STDERR "$count records\n" if $VERBOSE > 2; 2315 2316 # A whole new file 2317 } else { 2318 @_ = ($EXEC, "-9f"); 2319 @_ = map "\"$_\"", @_ if $^O eq "MSWin32"; 2320 $CMD = join " ", @_; 2321 print STDERR " Starting $CMD to file ... " if $VERBOSE > 2; 2322 # Redirect STDOUT to $FH 2323 open STDOUT, ">&", $FH or die "$THIS_FILE: $file: $!"; 2324 # Start the process 2325 if ($^O eq "MSWin32") { 2326 open $PH, "| $CMD" or die "$THIS_FILE: $CMD: $!"; 2327 } else { 2328 open $PH, "|-", @_ or die "$THIS_FILE: $CMD: $!"; 2329 } 2330 # Restore STDOUT 2331 open STDOUT, ">&", $STDOUT or die "$THIS_FILE: STDOUT: $!"; 2332 print STDERR "done\n" if $VERBOSE > 2; 2333 } 2334 2335 ($self->{"CMD"}, $self->{"PH"}) = ([@_], $PH); 2336 return; 2337} 2338 2339# readline: Read a line from the I/O stream 2340sub readline : method { 2341 local ($_, %_); 2342 my ($self, $PH); 2343 $self = $_[0]; 2344 $PH = $self->{"PH"}; 2345 return <$PH>; 2346} 2347 2348# write: Output data to the I/O stream 2349sub write : method { 2350 local ($_, %_); 2351 my ($self, $CMD, $PH); 2352 ($self, $_) = @_; 2353 ($CMD, $PH) = (join(" ", @{$self->{"CMD"}}), $self->{"PH"}); 2354 print $PH $_ or die "$THIS_FILE: $CMD: $!"; 2355 return; 2356} 2357 2358# close: Close the I/O stream 2359sub close : method { 2360 local ($_, %_); 2361 my ($self, $keep, $tmp, $file, $FH, $CMD, $PH); 2362 ($self, $keep, $tmp) = @_; 2363 $keep = KEEP_ALL if @_ < 2; 2364 ($file, $FH) = ($self->{"file"}, $self->{"FH"}); 2365 2366 # Restart the file 2367 if ($keep eq KEEP_RESTART || $keep eq KEEP_THISMONTH) { 2368 my ($CMD, $PH); 2369 # Empty the source file 2370 print STDERR " Emptying file ... " if $VERBOSE > 2; 2371 seek $FH, 0, SEEK_SET or die "$THIS_FILE: $file: $!"; 2372 truncate $FH, 0 or die "$THIS_FILE: $file: $!"; 2373 print STDERR "done\n" if $VERBOSE > 2; 2374 2375 # Create empty compressed content 2376 print STDERR " Applying empty compressed content ... " if $VERBOSE > 2; 2377 $EXEC = whereis "bzip2" if !defined $EXEC; 2378 @_ = ($EXEC, "-9f"); 2379 @_ = map "\"$_\"", @_ if $^O eq "MSWin32"; 2380 $CMD = join " ", @_; 2381 # Redirect STDOUT to $FH 2382 open STDOUT, ">&", $FH or die "$THIS_FILE: $file: $!"; 2383 # Start the process and end it 2384 if ($^O eq "MSWin32") { 2385 open $PH, "| $CMD" or die "$THIS_FILE: $CMD: $!"; 2386 } else { 2387 open $PH, "|-", @_ or die "$THIS_FILE: $CMD: $!"; 2388 } 2389 close $PH or die "$THIS_FILE: $CMD: $!"; 2390 # Restore STDOUT 2391 open STDOUT, ">&", $STDOUT or die "$THIS_FILE: STDOUT: $!"; 2392 print STDERR "done\n" if $VERBOSE > 2; 2393 } 2394 2395 ($CMD, $PH) = (join(" ", @{$self->{"CMD"}}), $self->{"PH"}); 2396 CORE::close $PH or die "$THIS_FILE: $CMD: $!"; 2397 CORE::close $FH or die "$THIS_FILE: $file: $!"; 2398 delete $self->{"PH"}; 2399 delete $self->{"CMD"}; 2400 delete $self->{"FH"}; 2401 delete $self->{"file"}; 2402 2403 # Delete the file 2404 if ($keep eq KEEP_DELETE) { 2405 print STDERR " Deleting file ... " if $VERBOSE > 2; 2406 unlink $file or die "$THIS_FILE: $file: $!"; 2407 print STDERR "done\n" if $VERBOSE > 2; 2408 } 2409 # Delete the temporary file if needed 2410 if (defined $tmp && -e $tmp) { 2411 unlink $tmp or die "$THIS_FILE: $tmp: $!"; 2412 } 2413 return; 2414} 2415 2416# _private::Format: The abstract log file format handler interface 2417package _private::Format; 2418use 5.008; 2419use strict; 2420use warnings; 2421BEGIN { 2422import main; 2423} 2424 2425use Date::Parse qw(str2time); 2426 2427# new: Initialize the log record format parser 2428sub new : method { bless {}, $_[0]; } 2429 2430# check_format: Check the record format and return an appropriate parser 2431sub check_format : method { 2432 local ($_, %_); 2433 my (@fmts, $record); 2434 $record = $_[1]; 2435 @fmts = qw(_private::Format::Apache _private::Format::Syslog 2436 _private::Format::NTP _private::Format::ApacheSSL 2437 _private::Format::ModfISO); 2438 foreach my $fmt (@fmts) { 2439 $_ = $fmt->new; 2440 print STDERR " Testing $_ ... " if $VERBOSE > 2; 2441 if ($_->match($record)) { 2442 print STDERR "match\n" if $VERBOSE > 2; 2443 return $_; 2444 } 2445 print STDERR "not match\n" if $VERBOSE > 2; 2446 } 2447 return undef; 2448} 2449 2450# match: Try matching my format and return the matching date text 2451# Empty. Implement it in the subclasses. 2452sub match : method { return undef; } 2453 2454# parse_month: Parse the month of the log file 2455sub parse_month : method { 2456 local ($_, %_); 2457 my $self; 2458 ($self, $_) = @_; 2459 return undef unless defined($_ = $self->match($_)); 2460 return undef unless defined($_ = str2time $_); 2461 return to_yyyymm $_; 2462} 2463 2464 2465# _private::Format::Apache: The Apache log file format handler 2466package _private::Format::Apache; 2467use 5.008; 2468use strict; 2469use warnings; 2470use base qw(_private::Format); 2471use overload ("\"\"" => sub { "Apache acess_log"; }); 2472 2473# match: Try matching my format and return the matching date text 2474sub match : method { 2475 return $_[1] =~ /^\S+ \S+ .*? \[(\d{2}\/[A-Z][a-z]{2}\/\d{4}:\d{2}:\d{2}:\d{2} [+\-]\d{4})\]/? 2476 $1: undef; 2477} 2478 2479 2480# _private::Format::Syslog: The Syslog log file format handler 2481package _private::Format::Syslog; 2482use 5.008; 2483use strict; 2484use warnings; 2485use base qw(_private::Format); 2486use overload ("\"\"" => sub { "Syslog"; }); 2487 2488# match: Try matching my format and return the matching date text 2489sub match : method { 2490 return $_[1] =~ /^([A-Z][a-z]{2} ?\d{1,2} \d{2}:\d{2}:\d{2}) /? 2491 $1: undef; 2492} 2493 2494 2495# _private::Format::NTP: The NTP log file format handler 2496package _private::Format::NTP; 2497use 5.008; 2498use strict; 2499use warnings; 2500use base qw(_private::Format); 2501use overload ("\"\"" => sub { "NTP"; }); 2502 2503# match: Try matching my format and return the matching date text 2504sub match : method { 2505 return $_[1] =~ /^( ?\d{1,2} [A-Z][a-z]{2} \d{2}:\d{2}:\d{2}) /? 2506 $1: undef; 2507} 2508 2509 2510# _private::Format::ApacheSSL: The Apache ssl_engine_log log file format handler 2511package _private::Format::ApacheSSL; 2512use 5.008; 2513use strict; 2514use warnings; 2515use base qw(_private::Format); 2516use overload ("\"\"" => sub { "Apache SSL engine log"; }); 2517 2518# match: Try matching my format and return the matching date text 2519sub match : method { 2520 return $_[1] =~ /^\[(\d{2}\/[A-Z][a-z]{2}\/\d{4} \d{2}:\d{2}:\d{2} )\d+\]/? 2521 $1: undef; 2522} 2523 2524 2525# _private::Format::ModfISO: The bracketed, modified ISO 8601 date/time log file format handler 2526# ISO 8601 should be 2007-11-14T14:23:35+0800. But it is hard to read. 2527# This is a similar format commonly-seen in many applications. 2528package _private::Format::ModfISO; 2529use 5.008; 2530use strict; 2531use warnings; 2532use base qw(_private::Format); 2533use overload ("\"\"" => sub { "modified ISO 8601 date/time"; }); 2534 2535# match: Try matching my format and return the matching date text 2536sub match : method { 2537 return $_[1] =~ /^\[(\d{4}-\d{2}-\d{2} \d{2}:\d{2}:\d{2} [+\-]\d{4})\]/? 2538 $1: undef; 2539} 2540 2541 2542__END__ 2543 2544=head1 NAME 2545 2546arclog - Archive the log files monthly 2547 2548=head1 SYNOPSIS 2549 2550 arclog [options] logfile... [output] 2551 arclog [-h|-v] 2552 2553=head1 DESCRIPTION 2554 2555F<arclog> archives the log files monthly. It strips off log entries 2556that belongs to previous months, and then compresses and saves them 2557to archived files named logfile.yyyymm.gz. 2558 2559Currently, F<arclog> supports Apache access log, Syslog, NTP, Apache 25601 SSL engine log and my own bracketed, modified ISO date/time log 2561file formats, and gzip and bzip2 compression methods. Several 2562software projects log (or can log) in a format compatible with the 2563Apache access log, like CUPS, ProFTPD, Pure-FTPd... etc., and 2564F<arclog> can archive their Apache-like log files, too. 2565 2566Notice: I<Archiving takes time>. To reduce the time occupying the 2567source log file, F<arclog> copies the content of the source log 2568file to a temporary working file and restart the source log file 2569first. Then F<arclog> can take its time working on the temporary 2570working file. However, please note: 2571 25721. If you have a huge log file (several hundreds of MBs), merely 2573copying still takes a lot of time. In that case, you had better stop 2574logging first, archive the log file and restart logging, to avoid 2575racing condition in writing. If you archive the log file periodly, 2576it shall not grow too big. 2577 25782. If F<arclog> stops in the middle of the execution, it will leave 2579a temporary working file. The next time F<arclog> runs, it will stop 2580when it sees that temporary working file. You have to process that 2581temporary working file first. That temporary working file is merely 2582a copy of the original log file. You can rename and archive it like 2583an ordinary log file to solve this. 2584 2585Do not sort unless you have a particular reason. Sorting has the 2586following potential problem: 2587 25881. Sorting may I<eat huge memory> on large log files. The amount of 2589the memory required depends on the number of records in each archived 2590month. Modern Linux and MSWin32 have memory consuming protection by 2591killing processes that eats too much memory, but it still takes 2592minutes, and your system will hang during that time. I do not know 2593the memory consuming protection on other operating systems. If you 2594try, you are at your own risk. 2595 25962. The time units of all recognized log formats are I<second>. 2597Log records happen in a same second will be sorted by the log file 2598order (if you are archiving several log files at a time) and then 2599the log record order. I try to ensure that the sorted archived 2600records are in a correct order of the happening events, but I cannot 2601guarantee. You have to watch out if the order in a second is 2602important. 2603 2604Be careful on the L<Syslog(2)|syslog/2> and NTP log files: 2605L<Syslog(2)|syslog/2> and NTP does not record the year. F<arclog> 2606uses L<Date::Parse(3)|Date::Parse/3> to parse the date, which assumes 2607the year between this month and last next month if the year is 2608missing. For ex., if today is 2001-06-08, it will then assume the 2609year between 2001-06-30 back to 2000-07-01 if the year is missing. I 2610think this is smart enough. However, if you do have a 2611L<Syslog(2)|syslog/2> or NTP log file that has records older than one 2612year, do not use F<arclog>. It will destroy your log file. 2613 2614If read from C<STDIN>, please note: 2615 26161. You I<MUST> specify the output prefix if you want to read from 2617C<STDIN>, since what it needs is an output pathname prefix, not an 2618output file. 2619 26202. C<STDIN> cannot be deleted, restarted or partially kept. If you 2621read from C<STDIN>, the keep mode will fall back to keep all. if 2622you archive several source log files including C<STDIN>, the keep 2623mode will fall back to keep all for all source log files, to prevent 2624disaster. 2625 26263. The answers of the C<ask> mode is obtained from C<STDIN>, too. 2627Since you have only one C<STDIN>, you cannot specify the C<ask> mode 2628while reading from C<STDIN>. It will fall back to the C<fail> mode 2629in that case. 2630 2631I suggest you to install L<File::MMagic(3)|File::MMagic/3> instead of 2632counting on the file executable. The internal magic file of 2633L<File::MMagic(3)|File::MMagic/3> seems to work better than the 2634L<file(1)|file/1> executable. F<arclog> treats everything not 2635L<gzip(1)|gzip/1> nor L<bzip2(1)|bzip2/1> compressed as plain text. 2636When a compressed log file is wrongly recognized as an image, 2637F<arclog> will treat it as plain text, read log records directly from 2638it and fail. This failure does not hurt the source log files, but is 2639still annoying. 2640 2641=head1 OPTIONS 2642 2643=over 2644 2645=item logfile 2646 2647The log file to be archived. Specify C<-> to read from C<STDIN>. 2648Multiple log files are supported. L<gzip(1)|gzip/1> or 2649L<bzip2(1)|bzip2/1> compressed files are supported, too. 2650 2651=item output 2652 2653The prefix of the output files. The output files will be named as 2654F<output.yyyymm>, ie: F<output.200101>, F<output.200101>. If not 2655specified, the default is the same as the log file. You must specify 2656this if you want to read from C<STDIN>. You cannot specify C<-> 2657(C<STDIN>), since this is only a name prefix, not the output file. 2658 2659=item -c,--compress method 2660 2661Specify the compression method for the archived files. Log files 2662usually have large number of simular lines. Compress them saves 2663you lots of disk spaces. (And this is why we want to I<archive> 2664them.) Currently the following compression methods are supported: 2665 2666=over 2667 2668=item g,gzip 2669 2670Compress with L<gzip(1)|gzip/1>. This is the default. F<arclog> 2671can use L<Compress::Zlib(3)|Compress::Zlib/3> to compress instead of 2672calling L<gzip(1)|gzip/1>. This can be safer and faster for not 2673calling foreign binaries. But if 2674L<Compress::Zlib(3)|Compress::Zlib/3> is not installed, it will try 2675to use L<gzip(1)|gzip/1> instead. If L<gzip(1)|gzip/1> is not 2676available, either, the program will fail. 2677 2678=item b,bzip2 2679 2680Compress with L<bzip2(1)|bzip2/1>. F<arclog> can use 2681L<Compress::Bzip2(3)|Compress::Bzip2/3> to compress instead of 2682calling L<bzip2(1)|bzip2/1>. This can be safer and faster for not 2683calling foreign binaries. But if 2684L<Compress::Bzip2(3)|Compress::Bzip2/3> is not installed, it will try 2685to use L<bzip2(1)|bzip2/1> instead. If L<bzip2(1)|bzip2/1> is not 2686available, either, the program will fail. 2687 2688=item n,none 2689 2690No compression at all. (Why? :p) 2691 2692=back 2693 2694=item --nocompress 2695 2696Do not compress the archived files. This is equal to 2697C<--compress none>. 2698 2699=item -s,--sort 2700 2701Sort the records by time (and then the record order). Sorting eats 2702huge memory and CPU, so it is disabled by default. See the 2703description above for a detailed illustration on sorting. 2704 2705=item --nosort 2706 2707Do not sort the records. This is the default. 2708 2709=item -o,--override mode 2710 2711Whether we should overwrite the existing archived files. Currently 2712the following modes are supported: 2713 2714=over 2715 2716=item o,overwrite 2717 2718Overwrite existing target files. You will lost these existing 2719records. Use with care. This is helpful if you are sure the master 2720log file has the most complete records. 2721 2722=item a,append 2723 2724Append the records to the existing target files. You may destroy the 2725log file completely by putting irrelevant entries altogether 2726accidently. Use with care. This is helpful if you append want to 2727merge 2 or more log files, for ex., 2 log files of different periods. 2728 2729=item i,ignore 2730 2731Ignore any existing target file, and discard all the records of those 2732months. You will lost these log records. Use with care. This is 2733helpful if you are supplying log records for the missing months, or 2734if you are merging the log records in a complex manner. 2735 2736=item f,fail 2737 2738Stop processing whenever a target file exists, to prevent destroying 2739existing files by accident. This should be mostly wanted when run 2740from some automatic mechanism, like L<crontab(1)|crontab/1>. So, 2741this is the default if no terminal is found at C<STDIN>. 2742 2743=item ask 2744 2745Ask you what to do when a target file exists. This should be most 2746wanted if you are running F<arclog> interactively. So, this is the 2747default if a terminal is found at C<STDIN>. The answers are read 2748from C<STDIN>. Since you have only one C<STDIN>, you cannot specify 2749this mode if you want read the log file from C<STDIN>. In that case, 2750it will fall back to the <samp>fail</samp> mode. Also, if 2751F<arclog> cannot get its answer from C<STDIN>, for ex., on a 2752closed C<STDIN> like L<crontab(1)|crontab/1>, it will fall back to 2753C<fail> mode. 2754 2755=back 2756 2757=item -k,--keep mode 2758 2759What to keep in the source file. Currently the following modes are 2760supported: 2761 2762=over 2763 2764=item a,all 2765 2766Keep the source file after records are archived. 2767 2768=item r,restart 2769 2770Restart the source file after records are archived. 2771 2772=item d,delete 2773 2774Delete the source file after records are archived. 2775 2776=item t,this-month 2777 2778Archive and strip records of previous months off from the log file. 2779Keep the records of this month in the source log file, to be archived 2780next month. This is designed to be run from L<crontab(1)|crontab/1> 2781monthly, so this is the default. 2782 2783=back 2784 2785=item -d, --debug 2786 2787Show the detailed debugging messages. 2788 2789=item -q, --quiet 2790 2791Shihhhhhh. Only yell when errors. 2792 2793=item -h, --help 2794 2795Display the help message and exit. 2796 2797=item -v, --version 2798 2799Output version information and exit. 2800 2801=back 2802 2803=head1 COPYRIGHT 2804 2805Copyright (c) 2001-2007 imacat. All rights reserved. 2806 2807This program is free software: you can redistribute it and/or modify 2808it under the terms of the GNU General Public License as published by 2809the Free Software Foundation, either version 3 of the License, or 2810(at your option) any later version. 2811 2812This program is distributed in the hope that it will be useful, 2813but I<WITHOUT ANY WARRANTY>; without even the implied warranty of 2814I<MERCHANTABILITY> or I<FITNESS FOR A PARTICULAR PURPOSE>. See the 2815GNU General Public License for more details. 2816 2817You should have received a copy of the GNU General Public License 2818along with this program. If not, see L<http://www.gnu.org/licenses/>. 2819 2820=head1 AUTHOR 2821 2822imacat <imacat@mail.imacat.idv.tw>. Please visit F<arclog>'s 2823websites at http://arclog.sourceforge.net/ and 2824http://www.imacat.idv.tw/tech/arclog.html . 2825 2826=head1 BUGS 2827 2828F<arclog> has a mailing list at SourceForge: 2829arclog-users@lists.sourceforge.net. It is for 2830F<arclog>'s users to discuss and report problems. Its web page is 2831at http://lists.sourceforge.net/lists/listinfo/arclog-users . 2832If you have any problem or question on F<arclog>, please go to 2833this page, join the list, and send your questions on this list. 2834Thank you. 2835 2836=head1 TODO 2837 2838=over 2839 2840=item Multi-lingual support 2841 2842Support multi-lingual, either with L<Text::Iconv(3)|Text::Iconv/3> or 2843perl 5.8.0's L<Encode(3)|Encode/3>. 2844 2845=back 2846 2847=head1 SEE ALSO 2848 2849L<gzip(1)|gzip/1>, L<zlib(3)|zlib/3>, 2850L<Compress::Zlib(3)|Compress::Zlib/3>, L<bzip2(1)|syslog/1>, 2851L<Compress::Bzip2(3)|Compress::Bzip2/3>, L<syslog(2)|syslog/2> 2852 2853=cut 2854