File Coverage

blib/lib/XAS/Apps/Rotate.pm
Criterion Covered Total %
statement 6 218 2.7
branch 0 78 0.0
condition 0 15 0.0
subroutine 2 20 10.0
pod 13 15 86.6
total 21 346 6.0


line stmt bran cond sub pod time code
1             package XAS::Apps::Rotate;
2              
3             our $VERSION = '0.04';
4              
5 1     1   623 use Try::Tiny;
  1         1  
  1         82  
6              
7             use XAS::Class
8 1         9 debug => 0,
9             version => $VERSION,
10             base => 'XAS::Lib::App',
11             utils => 'compress glob2regex',
12             constants => 'TRUE FALSE WILDCARD',
13             filesystem => 'Dir File',
14             constant => {
15             X2SECS => {
16             's' => 1,
17             'm' => 60,
18             'h' => 60 * 60,
19             'd' => 60 * 60 * 24,
20             'w' => 60 * 60 * 24 * 7
21             },
22             X2BYTES => {
23             b => 1,
24             k => 1024,
25             m => 1024 * 1024,
26             g => 1024 * 1024 * 1024,
27             t => 1024 * 1024 * 1204 * 1024
28             }
29             },
30 1     1   4 ;
  1         2  
31              
32             # ----------------------------------------------------------------------
33             # Global Variables
34             # ----------------------------------------------------------------------
35              
36             my $compressor;
37             my $modify_age;
38             my $create_age;
39             my $compress;
40             my $ifempty;
41             my $method;
42             my $missingok;
43             my $file_size;
44             my $create_new;
45             my $prolog;
46             my $epilog;
47             my $lines_or_files;
48             my $line_count;
49             my $file_count;
50             my $pause;
51              
52             my $zipcmd;
53             my $gzipcmd;
54             my $bzipcmd;
55             my $compcmd;
56             my $tailcmd;
57             my $logfile;
58              
59             my @wanted_files;
60              
61             # ----------------------------------------------------------------------
62             # Public Methods
63             # ----------------------------------------------------------------------
64              
65             sub run_cmd {
66 0     0 1   my $self = shift;
67 0           my $cmd = shift;
68              
69             #
70             # Runs a command and places the output into the logfile.
71             #
72              
73 0           $self->log->info("running '$cmd'");
74              
75 0           my @output = `$cmd 2>&1`;
76 0           foreach my $line (@output) {
77              
78 0           $self->log->info(compress($line));
79              
80             }
81              
82             }
83              
84             sub get_extension {
85 0     0 1   my $self = shift;
86              
87             #
88             # Return the compressor's extension.
89             #
90              
91 0           my $ext;
92              
93             # Try to guess what the right extension would be
94              
95 0 0         $ext = '.gz' if ($compressor =~ /gzip/i);
96 0 0         $ext = '.zip' if ($compressor =~ /zip/i);
97 0 0         $ext = '.bz2' if ($compressor =~ /bzip2/i);
98 0 0         $ext = '.Z' if ($compressor =~ /compress/i);
99              
100 0           return($ext);
101              
102             }
103              
104             sub is_true {
105 0     0 1   my $self = shift;
106 0           my $parm = shift;
107              
108             #
109             # Checks to see if the parameter is the string 't', 'true' or the number 1.
110             #
111              
112 0           my @truth = qw(yes true t 1 0e0);
113              
114 0           return scalar(grep {lc($parm) eq $_} @truth);
  0            
115              
116             }
117              
118              
119             sub is_false {
120 0     0 1   my $self = shift;
121 0           my $parm = shift;
122              
123             #
124             # Checks to see if the parameter is the string 'f' or 'false' or the number 0.
125             #
126              
127 0           my @truth = qw(no false f 0);
128              
129 0           return scalar(grep {lc($parm) eq $_} @truth);
  0            
130              
131             }
132              
133             sub is_oldder {
134 0     0 0   my $self = shift;
135 0           my $age_diff = shift;
136 0           my $age = shift;
137              
138             #
139             # Parses $age_diff and checks to see if the $age is newer than
140             # the current time minus $age_diff. That is we return
141             # TRUE if a file is too new based on the criteria $age_diff and $age
142             # and the implicit parameter: the current time.
143             #
144              
145 0 0         return FALSE unless $age_diff;
146 0           $self->log->debug("age_diff = $age_diff, age = $age");
147              
148             # Parse age string, e.g. 20 hours, 3 days, 4 weeks, etc.
149              
150 0 0         if ( $age_diff !~ /(\d+)\s+([smhdw])/i ) {
151              
152 0           $self->log->warn_msg('age_params', $age_diff);
153              
154 0           return FALSE;
155              
156             } else {
157              
158 0           my $sec_diff = $1 * X2SECS->{lc $2};
159 0           my $diff = time() - $sec_diff;
160 0           $self->log->debug("age = $age; diff = $diff");
161 0           my $ret = $age <= $diff;
162 0           $self->log->debug("is_oldder: $ret");
163              
164 0           return $ret;
165              
166             }
167              
168             }
169              
170             sub is_bigger {
171 0     0 1   my $self = shift;
172 0           my $size_spec = shift;
173 0           my $size = shift;
174              
175             #
176             # Parses $size_spec and checks to see if the $size is bigger than
177             # that. We return TRUE if a file is too big.
178             #
179              
180 0 0         return FALSE unless $size_spec;
181 0           $self->log->debug("size_spec = $size_spec, size = $size");
182              
183             # Parse size string, e.g. 20 MB, 3 bytes, 4 GB, etc.
184              
185 0 0         if ($size_spec !~ /(\d+)\s+([bkmgt])/i ) {
186              
187 0           $self->log->warn_msg('size_params', $size_spec);
188              
189 0           return FALSE;
190              
191             } else {
192              
193 0           my $max_size = $1 * X2BYTES->{lc $2};
194 0           my $ret = $size >= $max_size;
195              
196 0           $self->log->debug("is_bigger: $ret");
197              
198 0           return $ret;
199              
200             }
201              
202             }
203              
204             sub compress_file {
205 0     0 1   my $self = shift;
206 0           my $filename = shift;
207              
208             #
209             # Compress the .0th version of this file.
210             #
211              
212 0           my $cmd;
213             my $ext;
214              
215 0           $self->log->debug("entering compress_file()");
216              
217 0 0         if ($self->is_true($compress)) {
218              
219 0           my $file = $filename->path . ".0";
220 0           $ext = get_extension();
221 0           $self->log->info_msg('compressing', $file);
222              
223 0 0         if ($compressor =~ /zip/i) {
    0          
    0          
    0          
224              
225 0           $cmd = $zipcmd . " -m " . $file . $ext . " " . $file;
226 0           $self->log->debug("ZIP command = $cmd");
227              
228             } elsif ($compressor =~ /gzip/i) {
229              
230 0           $cmd = $gzipcmd . " " . $file;
231 0           $self->log->debug("GZIP command = $cmd");
232              
233             } elsif ($compressor =~ /bzip2/i) {
234              
235 0           $cmd = $bzipcmd . " " . $file;
236 0           $self->log->debug("BZIP2 command = $cmd");
237              
238             } elsif ($compressor =~ /compress/i) {
239              
240 0           $cmd = $compcmd . " " . $file;
241 0           $self->log->debug("COMPRESS command = $cmd");
242              
243             }
244              
245 0           $self->run_cmd($cmd);
246 0 0         $self->log->error_msg('nocompress', $file) if $?;
247              
248             }
249              
250 0           $self->log->debug("leaving compress_file()");
251              
252             }
253              
254             sub recreate_file {
255 0     0 1   my $self = shift;
256 0           my $filename = shift;
257              
258             #
259             # Recreate the file if needed.
260             #
261              
262 0           my $cmd;
263             my $tmpname;
264              
265 0           $self->log->debug("entering recreate_file()");
266 0           $self->log->debug("filename = " . $filename->path);
267              
268 0 0         if ($self->is_true($create_new)) {
269              
270 0 0         if ($lines_or_files =~ /files/i) {
271              
272             try {
273              
274             # thanks MS, Windows doesn't delete files in a timely
275             # manner, so the below code is needed to ensure file
276             # deletion...
277              
278 0     0     for (1..20) {
279              
280 0 0         last unless ($filename->exists);
281 0           $filename->delete();
282 0           sleep($pause);
283              
284             }
285              
286 0           $filename->open('w');
287              
288             } catch {
289              
290 0     0     my $ex = $_;
291 0           my $ref = ref($ex);
292              
293 0           $self->log->warn_msg('norecreate', $filename->path);
294              
295 0           };
296              
297             } else {
298              
299 0           $tmpname = $filename->path . '.0';
300              
301 0 0         if ($^O eq 'MSWin32') {
302              
303             #
304             # The Tail command from the Windows 2003 Resource Kit
305             # is broken. The -n switch does not work, so the default
306             # number of lines is used.
307             #
308              
309 0           $cmd = $tailcmd . " " . $tmpname . ' > ' . $filename->path;
310              
311             } else {
312              
313 0           $cmd = $tailcmd . ' -n ' . $line_count . ' ' . $tmpname . ' > ' . $filename->path;
314              
315             }
316              
317 0           $self->run_cmd($cmd);
318 0 0         $self->log->error_msg('notail', $line_count, $filename) if $?;
319              
320             }
321              
322             }
323              
324 0           $self->log->debug("leaving recreate_file()");
325              
326             }
327              
328             sub rotate_file {
329 0     0 1   my $self = shift;
330 0           my $filename = shift;
331              
332             #
333             # Rotate the files.
334             #
335              
336 0           my $x;
337             my $count;
338 0           my $tmpname;
339 0           my $prvname;
340 0           my $first = TRUE;
341 0           my $ext = $self->get_extension();
342              
343 0           $self->log->debug("entering rotate_file(); filename = $filename");
344              
345 0           for ($count = $file_count - 1; $count > 0; $count--) {
346              
347 0           $tmpname = File($filename->path . '.' . $count);
348 0 0         $tmpname = File($tmpname->path . $ext) if ($self->is_true($compress));
349 0           $self->log->debug("tmpname = $tmpname");
350              
351 0 0         if ($first) {
352              
353 0           unlink($tmpname->path);
354 0           $self->log->debug("removed $tmpname");
355 0           $first = FALSE;
356              
357             }
358              
359 0           $x = $count - 1;
360 0           $prvname = File($filename->path . '.' . $x);
361 0 0         $prvname = File($prvname->path . $ext) if ($self->is_true($compress));
362 0           $self->log->debug("prvname = $prvname");
363              
364 0 0         if ($prvname->exists) {
365              
366 0 0         if ($method =~ /copy/i) {
367              
368 0           $prvname->copy($tmpname->path);
369 0           $self->log->info_msg('copied', $prvname, $tmpname);
370              
371             } else {
372              
373 0           $prvname->move($tmpname->path);
374 0           $self->log->info_msg('moved', $prvname, $tmpname);
375              
376             }
377              
378             } else {
379              
380 0           $self->log->warn_msg('noexist', $prvname);
381              
382             }
383              
384             }
385              
386 0 0         if ($method =~ /copy/i) {
387              
388 0           $filename->copy($filename->path . '.0');
389 0           $self->log->info_msg('copied', $filename, $filename. '.0');
390              
391             } else {
392              
393 0           $filename->move($filename->path . '.0');
394 0           $self->log->info_msg('moved', $filename, $filename . '.0');
395              
396             }
397              
398 0           $self->log->debug("leaving rotate_file()");
399              
400             }
401              
402             sub process_files {
403 0     0 1   my $self = shift;
404              
405             #
406             # Process the files.
407             #
408              
409 0           my $ran_prolog = FALSE;
410            
411 0           $self->log->debug("entering process_files()");
412              
413 0 0 0       if (($prolog) && (scalar(@wanted_files) > 0)) {
414              
415            
416 0           $ran_prolog = TRUE;
417 0           $self->run_cmd($prolog);
418 0           sleep $pause;
419              
420             }
421              
422 0           while (my $filename = pop(@wanted_files)) {
423              
424 0           $self->log->debug("processing $filename->path");
425              
426 0           $self->rotate_file($filename);
427 0           $self->recreate_file($filename);
428 0           $self->compress_file($filename);
429              
430             }
431              
432 0 0 0       if (($epilog) && ($ran_prolog)) {
433              
434 0           $self->run_cmd($epilog);
435 0           sleep $pause;
436              
437             }
438              
439 0           $self->log->debug("leaving process_files()");
440              
441             }
442              
443             sub find_files {
444 0     0 1   my $self = shift;
445 0           my $from = shift;
446              
447             #
448             # Scan the local directory looking for files to rotate.
449             #
450              
451 0           $self->log->debug("entering find_files()");
452              
453 0           my @files;
454 0           my $fdir = Dir($from->volume, $from->dir);
455              
456 0           $self->log->info_msg('processing', $from->name, $fdir->path);
457              
458 0 0         if ($from->name =~ WILDCARD) {
459              
460 0           my $regex = glob2regex($from->name);
461 0           my $pattern = qr/$regex/;
462              
463 0           @files = grep ( $_->path =~ /$pattern/, $fdir->files() );
464              
465             } else {
466              
467 0           push(@files, $from);
468              
469             }
470              
471 0           foreach my $file (@files) {
472              
473 0 0         next unless($file->exists);
474              
475 0           my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,
476             $size,$atime,$mtime,$ctime,$blksize,$blocks) = $file->stat;
477              
478 0           $self->log->debug("file = $file, size = $size, ctime = $ctime, mtime = $mtime");
479              
480 0 0         if ($self->is_oldder($modify_age, $mtime)) {
    0          
    0          
481              
482 0 0 0       if (($size != 0) && ($self->is_false($ifempty))) {
483              
484 0           push(@wanted_files, $file);
485 0           $self->log->debug("added $file; modify-age");
486              
487             }
488              
489             } elsif ($self->is_oldder($create_age, $ctime)) {
490              
491 0 0 0       if (($size != 0) && ($self->is_false($ifempty))) {
492              
493 0           push(@wanted_files, $file);
494 0           $self->log->debug("added $file; create-age");
495              
496             }
497              
498             } elsif ($self->is_bigger($file_size, $size)) {
499              
500 0 0 0       if (($size != 0) && ($self->is_false($ifempty))) {
501              
502 0           push(@wanted_files, $file);
503 0           $self->log->debug("added $file; file-size");
504              
505             }
506              
507             }
508              
509             }
510              
511 0           $self->log->debug("the wanted_files array has $#wanted_files elements");
512              
513 0 0         if ($#wanted_files < 0) {
514              
515 0 0         $self->log->warn_msg('nomatch', $fdir->path, $from->name) if ($self->is_true($missingok));
516              
517             }
518              
519 0           $self->log->debug("leaving find_files()");
520              
521             }
522              
523             sub setup {
524 0     0 0   my $self = shift;
525              
526 0           $compressor = $self->cfg->val('settings', 'compressor', 'zip');
527 0           $zipcmd = $self->cfg->val('settings', 'zip-command', 'c:\bin\zip.exe');
528 0           $gzipcmd = $self->cfg->val('settings', 'gzip-command', 'c:\bin\gzip.exe');
529 0           $bzipcmd = $self->cfg->val('settings', 'bzip2-command', 'c:\bin\bzip2.exe');
530 0           $compcmd = $self->cfg->val('settings', 'compress-command', 'c:\bin\compress.exe');
531 0           $tailcmd = $self->cfg->val('settings', 'tail-command', 'c:\bin\tail.exe');
532              
533             }
534              
535             sub main {
536 0     0 1   my $self = shift;
537              
538 0           $self->setup();
539              
540 0           my $directory;
541 0           my @sections = $self->cfg->Sections();
542              
543 0           $self->log->info('start run');
544 0           $self->log->debug("found $#sections Sections");
545              
546 0           foreach my $section (@sections) {
547              
548 0           $self->log->debug("section = $section");
549            
550 0 0         next if ($section =~ /settings/i);
551              
552 0           $directory = File($section);
553              
554 0           $modify_age = $self->cfg->val($section, 'modify-age');
555 0           $create_age = $self->cfg->val($section, 'create-age');
556 0           $file_size = $self->cfg->val($section, 'file-size');
557 0           $compress = $self->cfg->val($section, 'compress', 'false');
558 0           $create_new = $self->cfg->val($section, 'create-new', 'false');
559 0           $ifempty = $self->cfg->val($section, 'ifempty', 'false');
560 0           $file_count = $self->cfg->val($section, 'file-count', '5');
561 0           $method = $self->cfg->val($section, 'method', 'copy');
562 0           $missingok = $self->cfg->val($section, 'missingok', 'true');
563 0           $line_count = $self->cfg->val($section, 'line-count', '10');
564 0           $prolog = $self->cfg->val($section, 'prolog');
565 0           $epilog = $self->cfg->val($section, 'epilog');
566 0           $pause = $self->cfg->val($section, 'pause', '10');
567 0           $lines_or_files = $self->cfg->val($section, 'lines-or-files', 'files');
568              
569 0           $self->find_files($directory);
570 0           $self->process_files();
571              
572             }
573              
574 0           $self->log->info('stop run');
575              
576             }
577              
578             sub options {
579 0     0 1   my $self = shift;
580              
581             return {
582             'cfgfile=s' => sub {
583 0     0     my $cfgfile = File($_[1]);
584 0           $self->env->cfgfile($cfgfile);
585             },
586 0           };
587              
588             }
589              
590             # ----------------------------------------------------------------------
591             # Private Methods
592             # ----------------------------------------------------------------------
593              
594             sub init {
595 0     0 1   my $class = shift;
596              
597 0           my $self = $class->SUPER::init(@_);
598              
599 0 0         $self->{cfg} = Config::IniFiles->new(
600             -file => $self->cfgfile->path,
601             -default => 'settings',
602             ) or $self->throw_msg(
603             'xas.apps.rotate.init.badini',
604             'badini',
605             $self->cfgfile->path
606             );
607              
608 0           return $self;
609              
610             }
611              
612             1;
613              
614             __END__