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