File Coverage

blib/lib/Comics.pm
Criterion Covered Total %
statement 55 286 19.2
branch 1 116 0.8
condition 0 35 0.0
subroutine 19 42 45.2
pod n/a
total 75 479 15.6


line stmt bran cond sub pod time code
1             #! perl
2              
3             # Author : Johan Vromans
4             # Created On : Fri Oct 21 09:18:23 2016
5             # Last Modified By: Johan Vromans
6             # Last Modified On: Fri Nov 16 10:49:04 2018
7             # Update Count : 389
8             # Status : Unknown, Use with caution!
9              
10 1     1   81795 use 5.012;
  1         3  
11 1     1   5 use strict;
  1         1  
  1         17  
12 1     1   4 use warnings;
  1         1  
  1         20  
13 1     1   502 use utf8;
  1         11  
  1         5  
14 1     1   24 use Carp;
  1         2  
  1         82  
15              
16             package Comics;
17              
18 1     1   304 use Comics::Version;
  1         3  
  1         40  
19              
20             our $VERSION = $Comics::Version::VERSION;
21              
22             package main;
23              
24             ################ Common stuff ################
25              
26 1     1   4 use strict;
  1         2  
  1         17  
27 1     1   4 use warnings;
  1         1  
  1         22  
28 1     1   361 use FindBin;
  1         877  
  1         53  
29 1     1   6 use File::Spec;
  1         2  
  1         14  
30 1     1   4 use File::Path qw();
  1         1  
  1         39  
31              
32             BEGIN {
33             # Add private library if it exists.
34 1 50   1   20 if ( -d "$FindBin::Bin/../lib" ) {
35 1         37 unshift( @INC, "$FindBin::Bin/../lib" );
36             }
37             }
38              
39             # Package name.
40             my $my_package = 'Sciurix';
41             # Program name.
42             my $my_name = "comics";
43              
44             ################ Command line parameters ################
45              
46 1     1   599 use Getopt::Long 2.13;
  1         10127  
  1         19  
47              
48             # Command line options.
49             my $spooldir = File::Spec->catdir( File::Spec->tmpdir, "Comics" );
50             my $statefile;
51             my $refresh;
52             my $activate = 0; # enable/disable
53             my $force; # process disabled modules as well
54             my $rebuild; # rebuild index, no fetching
55             my $list; # produce listing
56             my $verbose = 1; # verbose processing
57             my $reuse = 0; # reuse existing fetch results
58              
59             # Development options (not shown with -help).
60             my $debug = 0; # debugging
61             my $trace = 0; # trace (show process)
62             my $test = 0; # test mode.
63              
64             # Extra command line arguments are taken to be plugin names.
65             # If specified, only named plugins are included.
66             my $pluginfilter;
67              
68             ################ Presets ################
69              
70             ################ The Process ################
71              
72             # Statistics.
73             our $stats;
74              
75             sub init {
76 0     0     $stats =
77             { tally => 0,
78             fail => [],
79             loaded => 0,
80             uptodate => 0,
81             excluded => 0,
82             disabled => 0,
83             };
84              
85             # Process command line options.
86 0           app_options();
87              
88             # Post-processing.
89 0   0       $trace |= ($debug || $test);
90 0 0         $verbose = 255 if $debug;
91 0           $spooldir .= "/";
92 0           $spooldir =~ s;/+$;/;;
93              
94 0 0         File::Path::make_path( $spooldir, { verbose => 1 } )
95             unless -d $spooldir;
96              
97 0           $statefile = spoolfile(".state.json");
98              
99 0           $pluginfilter = ".";
100 0 0         if ( @ARGV ) {
101 0           $pluginfilter = "^(?:" . join("|", @ARGV) . ")\\.pm\$";
102             }
103 0           $pluginfilter = qr($pluginfilter)i;
104              
105             }
106              
107             sub main {
108              
109             # Initialize.
110 0     0     init();
111              
112             # Restore state of previous run.
113 0           get_state();
114              
115             # Load the plugins.
116 0           load_plugins();
117              
118             # Non-aggregating command: list.
119 0 0         if ( $list ) {
120 0           list_plugins();
121 0           return;
122             }
123              
124             # Non-aggregating command: enable/disable.
125 0 0         if ( $activate ) {
126 0           save_state();
127 0 0         return unless $rebuild;
128             }
129              
130 0 0         unless ( $rebuild ) {
131             # Run the plugins to fetch new images.
132 0           run_plugins();
133              
134             # Save the state.
135 0           save_state();
136             }
137              
138             # Gather the HTML fragments into a single index.html.
139 0           build();
140              
141             # Show processing statistics.
142 0           statistics();
143             }
144              
145             ################ State subroutines ################
146              
147 1     1   889 use JSON;
  1         8373  
  1         6  
148              
149             my $state;
150              
151             sub get_state {
152 0 0   0     if ( open( my $fd, '<', $statefile ) ) {
153 0           my $data = do { local $/; <$fd>; };
  0            
  0            
154 0           $state = JSON->new->decode($data);
155 0 0         if ( $refresh ) {
156             delete( $_->{md5} )
157 0           foreach values( %{ $state->{comics} } );
  0            
158             }
159             }
160             else {
161 0           $state = { comics => { } };
162              
163             }
164             }
165              
166             sub save_state {
167 0     0     unlink($statefile."~");
168 0           rename( $statefile, $statefile."~" );
169 0           open( my $fd, '>', $statefile );
170 0           print $fd JSON->new->canonical->pretty(1)->encode($state);
171 0           close($fd);
172             }
173              
174             ################ Plugin subroutines ################
175              
176             my @plugins;
177              
178             sub load_plugins {
179              
180 0 0   0     opendir( my $dh, $INC[0] . "/Comics/Plugin" )
181             or die( $INC[0] . "/Comics/Plugin: $!\n");
182              
183 0           while ( my $m = readdir($dh) ) {
184 0 0         next unless $m =~ /^[0-9A-Z].*\.pm$/;
185 0 0         next if $m eq 'Base.pm';
186 0           $stats->{loaded}++;
187 0 0         $stats->{excluded}++, next unless $m =~ $pluginfilter;
188              
189 0           debug("Loading $m...");
190 0           $m =~ s/\.pm$//;
191             # If the module is already loaded, remove it first.
192             # Otherwise the require won't produce the __PACKAGE__ result.
193 0           delete $INC{"Comics/Plugin/$m.pm"};
194 0           my $pkg = eval { require "Comics/Plugin/$m.pm" };
  0            
195 0 0         die("Comics/Plugin/$m.pm: $@\n") unless $pkg;
196 0 0         unless ( $pkg eq "Comics::Plugin::$m" ) {
197 0           warn("Skipped $m.pm (defines $pkg, should be Comics::Plugin::$m)\n");
198 0           next;
199             }
200 0           my $comic = $pkg->register;
201 0 0         next unless $comic;
202              
203 0           push( @plugins, $comic );
204 0           my $tag = $comic->{tag};
205              
206             # 'disabled' means that this plugin is permanently disabled.
207 0 0         my $activate = $comic->{disabled} ? -1 : $activate;
208              
209             # 'ondemand' means that this plugin is initially disabled, but
210             # can be enabled if desired.
211 0 0 0       if ( !$activate && $comic->{ondemand}
      0        
212             && !exists( $state->{comics}->{$tag} ) ) {
213 0           $activate = -1;
214             }
215              
216 0 0         if ( $activate > 0 ) {
    0          
217             delete( $state->{comics}->{$tag}->{disabled} )
218 0           }
219             elsif ( $activate < 0 ) {
220 0           $state->{comics}->{$tag}->{disabled} = 1;
221 0           delete( $state->{comics}->{$tag}->{md5} );
222 0           for ( qw( html jpg png gif ) ) {
223 0 0         next unless unlink( spoolfile( $tag . "." . $_ ) );
224 0           debug( "Removed: ", spoolfile( $tag . "." . $_ ) );
225 0           $rebuild++;
226             }
227 0           for ( $state->{comics}->{$tag}->{c_img} ) {
228 0 0         next unless defined;
229 0 0         next unless unlink( spoolfile($_) );
230 0           debug( "Removed: ", spoolfile($_) );
231 0           $rebuild++;
232             }
233             }
234              
235 0 0         if ( $state->{comics}->{$tag}->{disabled} ) {
236 0           $stats->{disabled}++;
237 0           debug("Comics::Plugin::$m: Disabled");
238             }
239              
240             }
241              
242 0 0         if ( $stats->{loaded} == $stats->{excluded} ) {
243 0           warn( "No matching plugins found\n" );
244             }
245             }
246              
247             sub list_plugins {
248              
249 0     0     my $lpl = length("Comics::Plugin::");
250 0           my $lft = length("Comics::Fetcher::");
251 0           my ( $l_name, $l_plugin, $l_fetcher ) = ( 0, 0, $lft+8 );
252              
253 0           my @tm;
254             @plugins =
255             sort { ($state->{comics}->{$a->{tag}}->{disabled} // 0) <=>
256             ($state->{comics}->{$b->{tag}}->{disabled} // 0) ||
257             $b->{update} <=> $a->{update} ||
258             $a->{name} cmp $b->{name}
259 0 0 0       }
      0        
      0        
260             map {
261 0   0       $_->{update} = $state->{comics}->{ $_->{tag} }->{update} ||= 0;
  0            
262 0           @tm = localtime($_->{update});
263 0           $_->{updated} = sprintf( "%04d-%02d-%02d %02d:%02d:%02d",
264             1900+$tm[5], 1+$tm[4], @tm[3,2,1,0] );
265 0 0         $l_name = length($_->{name}) if $l_name < length($_->{name});
266 0 0         $l_plugin = length(ref($_)) if $l_plugin < length(ref($_));
267 0           $_;
268             } @plugins;
269              
270 0           $l_plugin -= $lpl;
271 0           $l_fetcher -= $lft;
272 0           my $fmt = "%-${l_name}s %-${l_plugin}s %-${l_fetcher}s %-8s %s\n";
273 0           foreach my $comic ( @plugins ) {
274              
275 0           my $st = $state->{comics}->{ $comic->{tag} };
276 1     1   744 no strict 'refs';
  1         2  
  1         102  
277             printf( $fmt,
278             $comic->{name},
279             substr( ref($comic), $lpl ),
280 0           substr( ${ref($comic)."::"}{ISA}[0], $lft ),
281             $st->{disabled} ? "disabled" : "enabled",
282 0 0         $comic->{update} ? $comic->{updated} : "",
    0          
283             );
284             }
285              
286             }
287              
288 1     1   556 use LWP::UserAgent;
  1         43810  
  1         1394  
289              
290             our $ua;
291             our $uuid;
292              
293             sub run_plugins {
294              
295 0 0   0     unless ( $ua ) {
296 0           $ua = LWP::UserAgent::Custom->new;
297 0           $uuid = uuid();
298             }
299              
300 0           foreach my $comic ( @plugins ) {
301 0 0         warn("Plugin: ", $comic->{name}, "\n") if $verbose > 1;
302              
303             # Force existence of this comic's state otherwise
304             # it will be autovivified within the fetch method
305             # and never get outside.
306 0   0       $state->{comics}->{$comic->{tag}} ||= {};
307              
308             # Make the state accessible.
309 0           $comic->{state} = $state->{comics}->{$comic->{tag}};
310              
311             # Skip is disabled.
312 0 0 0       next if $comic->{state}->{disabled} && !$force;
313              
314             # Run it, trapping errors.
315 0           $stats->{tally}++;
316 0 0         unless ( eval { $comic->fetch($reuse); 1 } ) {
  0            
  0            
317 0           $comic->{state}->{fail} = $@;
318 0           debug($comic->{state}->{fail});
319 0           push( @{ $stats->{fail} },
320 0           [ $comic->{name}, $comic->{state}->{fail} ] );
321             }
322             }
323             }
324              
325             ################ Index subroutines ################
326              
327             sub build {
328              
329             # Change to the spooldir and collect all HTML fragments.
330 0 0   0     chdir($spooldir) or die("$spooldir: $!\n");
331 0           opendir( my $dir, "." );
332 0           my @files = grep { /^[^._].+(?
  0            
333 0           close($dir);
334 0 0         warn("Number of images = ", scalar(@files), "\n") if $debug;
335 0 0         $stats->{tally} = $stats->{uptodate} = @files if $rebuild;
336              
337             # Sort the fragments on last modification date.
338             @files =
339 0           map { $_->[0] }
340 0           sort { $b->[1] <=> $a->[1] }
341 0 0         grep { $force || ! $state->{comics}->{$_->[2]}->{disabled} }
342 0           map { ( my $t = $_ ) =~ s/\.\w+$//;
  0            
343 0           [ $_, (stat($_))[9], $t ] }
344             @files;
345              
346 0 0         if ( $debug > 1 ) {
347 0           warn("Images (sorted):\n");
348 0           warn(" $_\n") for @files;
349             }
350              
351             # Creat icon.
352 0 0         unless ( -s "comics.png" ) {
353 0           require Comics::Utils::Icon;
354 0           open( my $fd, '>:raw', "comics.png" );
355 0           print $fd Comics::Utils::Icon::icon();
356 0           close($fd);
357             }
358              
359             # Create a new index.html.
360 0           open( my $fd, '>:utf8', "index.html" );
361 0           preamble($fd);
362 0           htmlstats($fd);
363 0           for ( @files ) {
364 0 0         open( my $hh, '<:utf8', $_ )
365             or die("$_: $!");
366 0           print { $fd } <$hh>;
  0            
367 0           close($hh);
368             }
369 0           postamble($fd);
370 0           close($fd);
371             }
372              
373             sub preamble {
374 0     0     my ( $fd ) = @_;
375 0           print $fd <
376            
377            
378             Comics!
379            
380            
405            
406            
407            
408            
409             EOD
410             }
411              
412             sub postamble {
413 0     0     my ( $fd ) = @_;
414 0           print $fd <
415            
416            
417            
418             EOD
419             }
420              
421             sub htmlstats {
422 0     0     my ( $fd ) = @_;
423 0           print $fd <
424            
425            
426            

[Comics]Comics

427 0           Comics $VERSION, last run: @{[ "".localtime() ]}
@{[ statmsg(1) ]}

  0            
428            

429            
430            
431             EOD
432             }
433              
434             ################ Statistics subroutines ################
435              
436             sub statistics {
437 0 0   0     return unless $verbose;
438 0           warn( statmsg(), "\n" );
439             }
440              
441             sub statmsg {
442 0     0     my ( $html ) = @_;
443 0           my $loaded = $stats->{loaded};
444 0           my $tally = $stats->{tally};
445 0           my $uptodate = $stats->{uptodate};
446 0           my $fail = @{ $stats->{fail} };
  0            
447 0           my $disabled = $stats->{disabled};
448 0           my $excluded = $stats->{excluded};
449 0           my $new = $stats->{tally} - $stats->{uptodate} - $fail;
450 0           my $res = "Number of comics = $loaded (".
451             "$new new, " .
452             "$uptodate uptodate";
453 0 0         $res .= ", $disabled disabled" if $disabled;
454 0 0         $res .= ", $excluded excluded" if $excluded;
455 0 0         if ( $fail ) {
456 0 0         if ( $html ) {
457 0           $res .= ",
458 0           for ( @{ $stats->{fail} } ) {
  0            
459 0           my $t = $_->[1];
460 0           $t =~ s/ at .*//s;
461 0           $res .= $_->[0] . " ($t) ";
462             }
463 0           $res .= "\">$fail fail";
464             }
465             else {
466 0           $res .= ", $fail fail";
467             }
468             }
469 0           return "$res)";
470             }
471              
472             ################ Miscellaneous ################
473              
474             sub spoolfile {
475 0     0     my ( $file ) = @_;
476 0           File::Spec->catfile( $spooldir, $file );
477             }
478              
479             sub uuid {
480 0     0     my @chars = ( 'a'..'f', 0..9 );
481 0           my @string;
482 0           push( @string, $chars[int(rand(16))]) for (1..32);
483 0           splice( @string, 8, 0, '-');
484 0           splice( @string, 13, 0, '-');
485 0           splice( @string, 18, 0, '-');
486 0           splice( @string, 23, 0, '-');
487 0           return join('', @string);
488             }
489              
490             sub debug {
491 0 0   0     return unless $debug;
492 0           warn(@_,"\n");
493             }
494              
495             sub debugging {
496 0     0     $debug;
497             }
498              
499             ################ Command line handling ################
500              
501             sub app_options {
502 0     0     my $help = 0; # handled locally
503 0           my $ident = 0; # handled locally
504 0           my $man = 0; # handled locally
505              
506             my $pod2usage = sub {
507             # Load Pod::Usage only if needed.
508 0     0     require Pod::Usage;
509 0           Pod::Usage->import;
510 0           &pod2usage;
511 0           };
512              
513             # Process options.
514 0 0         if ( @ARGV > 0 ) {
515             GetOptions('spooldir=s' => \$spooldir,
516             'refresh' => \$refresh,
517             'rebuild' => \$rebuild,
518             'enable' => \$activate,
519 0     0     'disable' => sub { $activate = -1 },
520             'list' => \$list,
521             'force' => \$force,
522             'reuser' => \$reuse,
523             'ident' => \$ident,
524             'verbose+' => \$verbose,
525 0     0     'quiet' => sub { $verbose = 0 },
526 0 0         'trace' => \$trace,
527             'help|?' => \$help,
528             'man' => \$man,
529             'debug' => \$debug)
530             or $pod2usage->(2);
531             }
532 0 0 0       if ( $ident or $help or $man ) {
      0        
533 0           print STDERR ("This is $my_name version $VERSION\n");
534             }
535 0 0 0       if ( $man or $help ) {
536 0 0         $pod2usage->(1) if $help;
537 0 0         $pod2usage->(VERBOSE => 2) if $man;
538             }
539             }
540              
541             ################ Documentation ################
542              
543             =head1 NAME
544              
545             Comics - Comics aggregator in the style of Gotblah
546              
547             =head1 SYNOPSIS
548              
549             perl -MComics -e 'main()' -- [options] [plugin ...]
550              
551             or
552              
553             perl Comics.pm [options] [plugin ...]
554              
555             If the associated C tool has been installed properly:
556              
557             collect [options] [plugin ...]
558              
559             Options:
560             --spooldir=XXX where resultant images and index must be stored
561             --enable enables the plugins (no aggregation)
562             --disable disables the plugins (no aggregation)
563             --list lists the plugins (no aggregation)
564             --rebuild rebuild index.html, no fetching
565             --refresh consider all images as new
566             --ident shows identification
567             --help shows a brief help message and exits
568             --man shows full documentation and exits
569             --verbose provides more verbose information
570             --quiet provides no information unless failure
571              
572             =head1 OPTIONS
573              
574             =over 8
575              
576             =item B<--spooldir=>I
577              
578             Designates the spool area. Downloaded comics and index files are
579             written here.
580              
581             =item B<--enable>
582              
583             The plugins that are named on the command line will be enabled for
584             future runs of the aggregator. Default is to enable all plugins.
585              
586             Note that when this command is used, the program exits after enabling
587             the plugins. No aggregation takes place.
588              
589             =item B<--disable>
590              
591             The plugins that are named on the command line will be disabled for
592             future runs of the aggregator. Default is to disable all plugins.
593              
594             Note that when this command is used, the program exits after disabling
595             the plugins. No aggregation takes place.
596              
597             =item B<--list>
598              
599             Provides information on the selected (default: all) plugins.
600              
601             Note that when this command is used, no aggregation takes place.
602              
603             =item B<--rebuild>
604              
605             Recreates index.html in the spooldir without fetching new comics.
606              
607             =item B<--help>
608              
609             Prints a brief help message and exits.
610              
611             =item B<--man>
612              
613             Prints the manual page and exits.
614              
615             =item B<--ident>
616              
617             Prints program identification.
618              
619             =item B<--verbose>
620              
621             Provides more verbose information. This option may be repeated for
622             even more verbose information.
623              
624             =item B<--quiet>
625              
626             Silences verbose information.
627              
628             =item I
629              
630             If present, process only the specified plugins.
631              
632             This is used for disabling and enabling plugins, but it can also be
633             used to test individual plugins.
634              
635             =back
636              
637             =head1 DESCRIPTION
638              
639             The normal task of this program is to perform aggregation. it will
640             load the available plugins and run all of them.
641              
642             The plugins will examine the contents of comics sites and update the
643             'cartoon of the day' in the spool area.
644              
645             Upon completion, an index.html is generated in the spool area to view
646             the comics collection.
647              
648             It is best to run this program from the spool area itself.
649              
650             =head2 Special commands
651              
652             Note that no aggregation is performed when using any of these commands.
653              
654             With command line option B<--list> a listing of the plugins is produced.
655              
656             Plugins can be enabled and disabled with B<--enable> and B<--disable>
657             respectively.
658              
659             =head1 PLUGINS
660              
661             B This program assumes that the plugins can be found in
662             C<../lib> relative to the location of the executable file.
663              
664             All suitable CIC<.pm> files are examined
665             and loaded.
666              
667             Plugins are derived from Fetcher classes, see below.
668              
669             See L for a fully commented plugin.
670              
671             =head1 FETCHERS
672              
673             Fetchers implement different fetch strategies. Currently provided are:
674              
675             L - fetch a comic by loading and examining a series of URLs.
676              
677             L - fetch a comic by URL.
678              
679             L - fetch a comic by examining the comic's home page.
680              
681             L - fetch a comic from a GoComics site.
682              
683             =cut
684              
685             package LWP::UserAgent::Custom;
686 1     1   9 use parent qw(LWP::UserAgent);
  1         2  
  1         5  
687              
688 1     1   513 use HTTP::Cookies;
  1         5683  
  1         154  
689             my $cookie_jar;
690              
691             sub new {
692 0     0     my ( $pkg ) = @_;
693 0           my $self = $pkg->SUPER::new();
694 0           bless $self, $pkg;
695              
696 0           $self->agent('Mozilla/5.0 (Windows NT 6.1; Win64; x64; rv:60.0) Gecko/20100101 Firefox/60.0');
697 0           $self->timeout(10);
698 0   0       $cookie_jar ||= HTTP::Cookies->new
699             (
700             file => ::spoolfile(".lwp_cookies.dat"),
701             autosave => 1,
702             ignore_discard => 1,
703             );
704 0           $self->cookie_jar($cookie_jar);
705              
706 0           return $self;
707             }
708              
709             sub get {
710 0     0     my ( $self, $url ) = @_;
711              
712 0           my $res;
713              
714 0           my $sleep = 1;
715 0           for ( 0..4 ) {
716 0           $res = $self->SUPER::get($url);
717 0           $cookie_jar->save;
718 0 0         last if $res->is_success;
719             # Some sites block LWP queries. Show why.
720 0 0         if ( $res->status_line =~ /^403/ ) {
721 1     1   493 use Data::Dumper;
  1         5569  
  1         164  
722 0           warn(Dumper($res));
723 0           exit;
724             }
725 0 0         last if $res->status_line !~ /^5/; # not temp fail
726 0 0         print STDERR "Retry..." if $verbose;
727 0           sleep $sleep;
728 0           $sleep += $sleep;
729             }
730              
731 0           return $res;
732             }
733              
734             1;
735              
736             =head1 AUTHOR
737              
738             Johan Vromans, C<< >>
739              
740             =head1 SUPPORT
741              
742             Development of this module takes place on GitHub:
743             https://github.com/sciurius/comics .
744              
745             You can find documentation for this module with the perldoc command.
746              
747             perldoc Comics
748              
749             Please report any bugs or feature requests using the issue tracker on
750             GitHub.
751              
752             =head1 ACKNOWLEDGEMENTS
753              
754             The people behind Gotblah, for creating the original tool.
755              
756             =head1 LICENSE
757              
758             Copyright (C) 2016,2018 Johan Vromans,
759              
760             This module is free software. You can redistribute it and/or
761             modify it under the terms of the Artistic License 2.0.
762              
763             This program is distributed in the hope that it will be useful,
764             but without any warranty; without even the implied warranty of
765             merchantability or fitness for a particular purpose.
766              
767             =cut
768              
769             package main;
770              
771             unless ( caller ) {
772             main();
773             }
774              
775             1;