source: trunk/gsdl/perllib/plugins/BasPlug.pm@ 10229

Last change on this file since 10229 was 10229, checked in by kjdon, 19 years ago

fixed up some stuff for printing args (pluginfo.pl, classinfo.pl)
  • Property svn:keywords set to Author Date Id Revision
File size: 39.7 KB
Line 
1###########################################################################
2#
3# BasPlug.pm -- base class for all the import plugins
4# A component of the Greenstone digital library software
5# from the New Zealand Digital Library Project at the
6# University of Waikato, New Zealand.
7#
8# Copyright (C) 1999-2005 New Zealand Digital Library Project
9#
10# This program is free software; you can redistribute it and/or modify
11# it under the terms of the GNU General Public License as published by
12# the Free Software Foundation; either version 2 of the License, or
13# (at your option) any later version.
14#
15# This program is distributed in the hope that it will be useful,
16# but WITHOUT ANY WARRANTY; without even the implied warranty of
17# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18# GNU General Public License for more details.
19#
20# You should have received a copy of the GNU General Public License
21# along with this program; if not, write to the Free Software
22# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
23#
24###########################################################################
25
26package BasPlug;
27
28BEGIN {
29 die "GSDLHOME not set\n" unless defined $ENV{'GSDLHOME'};
30}
31
32eval {require bytes};
33
34# suppress the annoying "subroutine redefined" warning that various
35# plugins cause under perl 5.6
36$SIG{__WARN__} = sub {warn($_[0]) unless ($_[0] =~ /Subroutine\s+\S+\sredefined/)};
37
38use strict; no strict 'subs';
39
40use File::Basename;
41
42use Kea;
43use parsargv;
44use multiread;
45use encodings;
46use cnseg;
47use acronym;
48use textcat;
49use doc;
50eval "require diagnostics"; # some perl distros (eg mac) don't have this
51use DateExtract;
52use ghtml;
53use gsprintf 'gsprintf';
54use printusage;
55#$%^
56use parse2;
57
58
59use GISBasPlug;
60
61@BasPlug::ISA = ( GISBasPlug );
62
63my $unicode_list =
64 [ { 'name' => "ascii",
65 'desc' => "{BasPlug.input_encoding.ascii}" },
66 { 'name' => "utf8",
67 'desc' => "{BasPlug.input_encoding.utf8}" },
68 { 'name' => "unicode",
69 'desc' => "{BasPlug.input_encoding.unicode}" } ];
70
71my $auto_unicode_list =
72 [ { 'name' => "auto",
73 'desc' => "{BasPlug.input_encoding.auto}" } ];
74
75my $arguments =
76 [ { 'name' => "process_exp",
77 'desc' => "{BasPlug.process_exp}",
78 'type' => "regexp",
79 'deft' => "",
80 'reqd' => "no" },
81 { 'name' => "block_exp",
82 'desc' => "{BasPlug.block_exp}",
83 'type' => "regexp",
84 'deft' => "",
85 'reqd' => "no" },
86 { 'name' => "smart_block",
87 'desc' => "{BasPlug.smart_block}",
88 'type' => "flag",
89 'reqd' => "no" },
90 { 'name' => "associate_ext",
91 'desc' => "{BasPlug.associate_ext}",
92 'type' => "string",
93 'reqd' => "no" },
94 { 'name' => "input_encoding",
95 'desc' => "{BasPlug.input_encoding}",
96 'type' => "enum",
97 'list' => $auto_unicode_list,
98 'reqd' => "no" ,
99 'deft' => "auto" } ,
100 { 'name' => "default_encoding",
101 'desc' => "{BasPlug.default_encoding}",
102 'type' => "enum",
103 'list' => $unicode_list,
104 'reqd' => "no",
105 'deft' => "utf8" },
106 { 'name' => "extract_language",
107 'desc' => "{BasPlug.extract_language}",
108 'type' => "flag",
109 'reqd' => "no" },
110 { 'name' => "default_language",
111 'desc' => "{BasPlug.default_language}",
112 'type' => "language",
113 'deft' => "en",
114 'char_length' => "2",
115 'reqd' => "no" },
116 { 'name' => "extract_acronyms",
117 'desc' => "{BasPlug.extract_acronyms}",
118 'type' => "flag",
119 'reqd' => "no" },
120 { 'name' => "markup_acronyms",
121 'desc' => "{BasPlug.markup_acronyms}",
122 'type' => "flag",
123 'reqd' => "no" },
124 { 'name' => "extract_keyphrases",
125 'desc' => "{BasPlug.extract_keyphrases}",
126 'type' => "flag",
127 'reqd' => "no" },
128 { 'name' => "extract_keyphrase_options",
129 'desc' => "{BasPlug.extract_keyphrase_options}",
130 'type' => "string",
131 'deft' => "",
132 'reqd' => "no" },
133 { 'name' => "first",
134 'desc' => "{BasPlug.first}",
135 'type' => "string",
136 'reqd' => "no" },
137 { 'name' => "extract_email",
138 'desc' => "{BasPlug.extract_email}",
139 'type' => "flag",
140 'reqd' => "no" },
141 { 'name' => "extract_historical_years",
142 'desc' => "{BasPlug.extract_historical_years}",
143 'type' => "flag",
144 'reqd' => "no" },
145 { 'name' => "maximum_year",
146 'desc' => "{BasPlug.maximum_year}",
147 'type' => "int",
148 'deft' => (localtime)[5]+1900,
149 'char_length' => "4",
150 #'range' => "2,100",
151 'reqd' => "no"},
152 { 'name' => "maximum_century",
153 'desc' => "{BasPlug.maximum_century}",
154 'type' => "string",
155 'deft' => "-1",
156 'reqd' => "no" },
157 { 'name' => "no_bibliography",
158 'desc' => "{BasPlug.no_bibliography}",
159 'type' => "flag",
160 'reqd' => "no"},
161 { 'name' => "no_cover_image",
162 'desc' => "{BasPlug.no_cover_image}",
163 'type' => "flag",
164 'reqd' => "no" },
165 { 'name' => "extract_keyphrases",
166 'desc' => "{BasPlug.extract_keyphrases}",
167 'type' => "flag",
168 'reqd' => "no",
169 'hiddengli' => "yes" },
170 { 'name' => "extract_keyphrase_options",
171 'desc' => "{BasPlug.extract_keyphrase_options}",
172 'type' => "string",
173 'reqd' => "no",
174 'hiddengli' => "yes" },
175 { 'name' => "separate_cjk",
176 'desc' => "{BasPlug.separate_cjk}",
177 'type' => "flag",
178 'reqd' => "no",
179 'hiddengli' => "yes" },
180 { 'name' => "smart_block",
181 'desc' => "{BasPlug.smart_block}",
182 'type' => "flag",
183 'reqd' => "no",
184 'hiddengli' => "yes" },
185 { 'name' => "new_extract_email",
186 'desc' => "",
187 'type' => "flag",
188 'reqd' => "no",
189 'hiddengli' => "yes" } ];
190
191my $gis_arguments =
192 [ { 'name' => "extract_placenames",
193 'desc' => "{GISBasPlug.extract_placenames}",
194 'type' => "flag",
195 'reqd' => "no" },
196 { 'name' => "gazetteer",
197 'desc' => "{GISBasPlug.gazetteer}",
198 'type' => "string",
199 'reqd' => "no" },
200 { 'name' => "place_list",
201 'desc' => "{GISBasPlug.place_list}",
202 'type' => "flag",
203 'reqd' => "no" } ];
204
205
206my $options = { 'name' => "BasPlug",
207 'desc' => "{BasPlug.desc}",
208 'abstract' => "yes",
209 'inherits' => "no",
210 'args' => $arguments };
211
212
213
214
215sub get_arguments
216{
217 my $self = shift(@_);
218 my $optionlistref = $self->{'option_list'};
219 my @optionlist = @$optionlistref;
220 my $pluginoptions = pop(@$optionlistref);
221 my $pluginarguments = $pluginoptions->{'args'};
222 return $pluginarguments;
223}
224
225
226sub print_xml_usage
227{
228 my $self = shift(@_);
229
230 # XML output is always in UTF-8
231 gsprintf::output_strings_in_UTF8;
232
233 PrintUsage::print_xml_header();
234 $self->print_xml();
235}
236
237
238sub print_xml
239{
240 my $self = shift(@_);
241
242 my $optionlistref = $self->{'option_list'};
243 my @optionlist = @$optionlistref;
244 my $pluginoptions = shift(@$optionlistref);
245 return if (!defined($pluginoptions));
246
247 gsprintf(STDERR, "<PlugInfo>\n");
248 gsprintf(STDERR, " <Name>$pluginoptions->{'name'}</Name>\n");
249 my $desc = gsprintf::lookup_string($pluginoptions->{'desc'});
250 $desc =~ s/</&amp;lt;/g; # doubly escaped
251 $desc =~ s/>/&amp;gt;/g;
252
253 gsprintf(STDERR, " <Desc>$desc</Desc>\n");
254 gsprintf(STDERR, " <Abstract>$pluginoptions->{'abstract'}</Abstract>\n");
255 gsprintf(STDERR, " <Inherits>$pluginoptions->{'inherits'}</Inherits>\n");
256 gsprintf(STDERR, " <Explodes>" . ($pluginoptions->{'explodes'} || "no") . "</Explodes>\n");
257 gsprintf(STDERR, " <Arguments>\n");
258 if (defined($pluginoptions->{'args'})) {
259 &PrintUsage::print_options_xml($pluginoptions->{'args'});
260 }
261
262 # Recurse up the plugin hierarchy
263 $self->print_xml();
264
265 gsprintf(STDERR, " </Arguments>\n");
266 gsprintf(STDERR, "</PlugInfo>\n");
267}
268
269
270sub print_txt_usage
271{
272 my $self = shift(@_);
273 # Print the usage message for a plugin (recursively)
274 my $descoffset = $self->determine_description_offset(0);
275 $self->print_plugin_usage($descoffset, 1);
276}
277
278
279sub determine_description_offset
280{
281 my $self = shift(@_);
282 my $maxoffset = shift(@_);
283
284 my $optionlistref = $self->{'option_list'};
285 my @optionlist = @$optionlistref;
286 my $pluginoptions = shift(@$optionlistref);
287 return $maxoffset if (!defined($pluginoptions));
288
289 # Find the length of the longest option string of this plugin
290 my $pluginargs = $pluginoptions->{'args'};
291 if (defined($pluginargs)) {
292 my $longest = &PrintUsage::find_longest_option_string($pluginargs);
293 if ($longest > $maxoffset) {
294 $maxoffset = $longest;
295 }
296 }
297
298 # Recurse up the plugin hierarchy
299 $maxoffset = $self->determine_description_offset($maxoffset);
300 $self->{'option_list'} = \@optionlist;
301 return $maxoffset;
302}
303
304
305sub print_plugin_usage
306{
307 my $self = shift(@_);
308 my $descoffset = shift(@_);
309 my $isleafclass = shift(@_);
310
311 my $optionlistref = $self->{'option_list'};
312 my @optionlist = @$optionlistref;
313 my $pluginoptions = shift(@$optionlistref);
314 return if (!defined($pluginoptions));
315
316 my $pluginname = $pluginoptions->{'name'};
317 my $pluginargs = $pluginoptions->{'args'};
318 my $plugindesc = $pluginoptions->{'desc'};
319
320 # Produce the usage information using the data structure above
321 if ($isleafclass) {
322 if (defined($plugindesc)) {
323 gsprintf(STDERR, "$plugindesc\n\n");
324 }
325 gsprintf(STDERR, " {common.usage}: plugin $pluginname [{common.options}]\n\n");
326 }
327
328 # Display the plugin options, if there are some
329 if (defined($pluginargs)) {
330 # Calculate the column offset of the option descriptions
331 my $optiondescoffset = $descoffset + 2; # 2 spaces between options & descriptions
332
333 if ($isleafclass) {
334 gsprintf(STDERR, " {common.specific_options}:\n");
335 }
336 else {
337 gsprintf(STDERR, " {common.general_options}:\n", $pluginname);
338 }
339
340 # Display the plugin options
341 &PrintUsage::print_options_txt($pluginargs, $optiondescoffset);
342 }
343
344 # Recurse up the plugin hierarchy
345 $self->print_plugin_usage($descoffset, 0);
346 $self->{'option_list'} = \@optionlist;
347}
348
349
350sub new {
351 # Set Encodings to the list!!
352
353 my $e = $encodings::encodings;
354 foreach my $enc (sort {$e->{$a}->{'name'} cmp $e->{$b}->{'name'}} keys (%$e))
355 {
356 my $hashEncode =
357 {'name' => $enc,
358 'desc' => $e->{$enc}->{'name'}};
359
360 push(@{$unicode_list},$hashEncode);
361 }
362
363 push(@{$auto_unicode_list},@{$unicode_list});
364
365 # Start the BasPlug Constructor
366 my $class = shift (@_);
367 my ($pluginlist,$args,$hashArgOptLists) = @_;
368 push(@$pluginlist, $class);
369 my $plugin_name = (defined $pluginlist->[0]) ? $pluginlist->[0] : $class;
370
371 if(defined $arguments){ push(@{$hashArgOptLists->{"ArgList"}},@{$arguments});}
372 if(defined $options) { push(@{$hashArgOptLists->{"OptList"}},$options)};
373
374 if (GISBasPlug::has_mapdata()) {
375 push(@$arguments,@$gis_arguments);
376 }
377
378 my $self = {};
379 if(!parse2::parse($args,$hashArgOptLists->{"ArgList"},$self))
380 {
381 my $classTempClass = bless $self, $class;
382 &gsprintf(STDERR, "\n{BasPlug.bad_general_option}\n", $plugin_name);
383 $classTempClass->print_txt_usage(""); # Use default resource bundle
384 die "\n";
385 }
386
387 # else parsing was successful.
388
389 $self->{'plugin_type'} = $plugin_name;
390 $self->{'outhandle'} = STDERR;
391 $self->{'textcat'} = new textcat();
392 $self->{'num_processed'} = 0;
393 $self->{'num_not_processed'} = 0;
394 $self->{'num_blocked'} = 0;
395 $self->{'num_archives'} = 0;
396 $self->{'cover_image'} = 1; # cover image is on by default
397 $self->{'cover_image'} = 0 if ($self->{'no_cover_image'});
398 $self->{'file_blocks'} = {};
399 $self->{'option_list'} = $hashArgOptLists->{"OptList"};
400
401 my $associate_ext = $self->{'associate_ext'};
402 if ((defined $associate_ext) && ($associate_ext ne "")) {
403 my @exts = split(/,/,$associate_ext);
404
405 my %associate_ext_lookup = ();
406 foreach my $e (@exts) {
407 $associate_ext_lookup{$e} = 1;
408 }
409
410 $self->{'associate_ext_lookup'} = \%associate_ext_lookup;
411 }
412
413 $self->{'shared_fileroot'} = {};
414 $self->{'file_blocks'} = {};
415
416 if ($self->{'extract_placenames'}) {
417
418 my $outhandle = $self->{'outhandle'};
419
420 my $places_ref
421 = GISBasPlug::loadGISDatabase($outhandle,$self->{'gazetteer'});
422
423 if (!defined $places_ref) {
424 print $outhandle "Warning: Error loading mapdata gazetteer \"$self->{'gazetteer'}\"\n";
425 print $outhandle " No placename extraction will take place.\n";
426 $self->{'extract_placenames'} = undef;
427 }
428 else {
429 $self->{'places'} = $places_ref;
430 }
431 }
432 return bless $self, $class;
433
434}
435
436# initialize BasPlug options
437# if init() is overridden in a sub-class, remember to call BasPlug::init()
438sub init {
439 my $self = shift (@_);
440 my ($verbosity, $outhandle, $failhandle) = @_;
441
442 # verbosity is passed through from the processor
443 $self->{'verbosity'} = $verbosity;
444
445 # as are the outhandle and failhandle
446 $self->{'outhandle'} = $outhandle if defined $outhandle;
447 $self->{'failhandle'} = $failhandle;
448
449 # set process_exp and block_exp to defaults unless they were
450 # explicitly set
451
452 if ((!$self->is_recursive()) and
453 (!defined $self->{'process_exp'}) || ($self->{'process_exp'} eq "")) {
454
455 $self->{'process_exp'} = $self->get_default_process_exp ();
456 if ($self->{'process_exp'} eq "") {
457 warn ref($self) . " Warning: Non-recursive plugin has no process_exp\n";
458 }
459 }
460
461 if ((!defined $self->{'block_exp'}) || ($self->{'block_exp'} eq "")) {
462 $self->{'block_exp'} = $self->get_default_block_exp ();
463 }
464}
465
466sub begin {
467 my $self = shift (@_);
468 my ($pluginfo, $base_dir, $processor, $maxdocs) = @_;
469 $self->initialise_extractors();
470}
471
472sub end {
473 # potentially called at the end of each plugin pass
474 # import.pl only has one plugin pass, but buildcol.pl has multiple ones
475
476 my ($self) = @_;
477 $self->finalise_extractors();
478}
479
480sub deinit {
481 # called only once, after all plugin passes have been done
482
483 my ($self) = @_;
484}
485
486# this function should be overridden to return 1
487# in recursive plugins
488sub is_recursive {
489 my $self = shift (@_);
490
491 return 0;
492}
493
494sub get_default_block_exp {
495 my $self = shift (@_);
496
497 return "";
498}
499
500sub get_default_process_exp {
501 my $self = shift (@_);
502
503 return "";
504}
505
506# default implementation is to do nothing.
507sub store_block_files
508{
509 my $self =shift (@_);
510 my ($filename) = @_;
511 return;
512}
513
514#default implementation is to block a file with same name as this, but extension jpg or JPG, if cover_images is on.
515sub block_cover_image
516{
517 my $self =shift (@_);
518 my ($filename) = @_;
519 if ($self->{'cover_image'}) {
520 my $coverfile = $filename;
521 $coverfile =~ s/\.[^\\\/\.]+$/\.jpg/;
522 if (!-e $coverfile) {
523 $coverfile =~ s/jpg$/JPG/;
524 }
525 if (-e $coverfile) {
526 $self->{'file_blocks'}->{$coverfile} = 1;
527 }
528 }
529
530 return;
531}
532
533sub metadata_read {
534 my $self = shift (@_);
535 my ($pluginfo, $base_dir, $file, $metadata, $extrametakeys, $extrametadata, $processor, $maxdocs, $gli) = @_;
536 # Keep track of filenames with same root but different extensions
537 # Used to support -associate_ext
538
539 my $associate_ext = $self->{'associate_ext'};
540 if ((defined $associate_ext) && ($associate_ext ne "")) {
541
542 my ($file_prefix,$file_ext) = ($file =~ m/^(.*)\.(.*?)$/);
543 if ((defined $file_prefix) && (defined $file_ext)) {
544
545 my $shared_fileroot = $self->{'shared_fileroot'};
546 if (!defined $shared_fileroot->{$file_prefix}) {
547 my $file_prefix_rec = { 'tie_to' => undef, 'exts' => {} };
548 $shared_fileroot->{$file_prefix} = $file_prefix_rec;
549 }
550
551 my $file_prefix_rec = $shared_fileroot->{$file_prefix};
552
553 my $process_exp = $self->{'process_exp'};
554
555 if ($file =~ m/$self->{'process_exp'}/) {
556 # This is the document the others should be tied to
557 $file_prefix_rec->{'tie_to'} = $file_ext;
558 }
559 else {
560 if (defined $self->{'associate_ext_lookup'}->{$file_ext}) {
561 $file_prefix_rec->{'exts'}->{$file_ext} = 1;
562 }
563 }
564 }
565 }
566
567 # now check whether we are actually processing this
568 my $filename = $file;
569 $filename = &util::filename_cat ($base_dir, $file) if $base_dir =~ /\w/;
570 if ($self->{'process_exp'} eq "" || $filename !~ /$self->{'process_exp'}/ || !-f $filename) {
571 return undef; # can't recognise
572 }
573
574 # do smart blocking if appropriate
575 if (defined $self->{'smart_block'}) {
576 $self->block_cover_image($filename);
577 $self->store_block_files($filename);
578 }
579
580 return 1;
581}
582
583sub tie_to_filename
584{
585 my $self = shift (@_);
586
587 my ($file_ext,$file_prefix_rec) = @_;
588
589 if (defined $file_prefix_rec) {
590 my $tie_to = $file_prefix_rec->{'tie_to'};
591
592 if (defined $tie_to) {
593 if ($tie_to eq $file_ext) {
594 return 1;
595 }
596 }
597 }
598
599 return 0;
600}
601
602sub tie_to_assoc_file
603{
604 my $self = shift (@_);
605 my ($file_ext,$file_prefix_rec) = @_;
606
607 if (defined $file_prefix_rec) {
608 my $tie_to = $file_prefix_rec->{'tie_to'};
609 if (defined $tie_to) {
610
611 my $exts = $file_prefix_rec->{'exts'};
612
613 my $has_file_ext = $exts->{$file_ext};
614
615 if ($has_file_ext) {
616 return 1;
617 }
618 }
619 }
620
621 return 0;
622}
623
624
625sub associate_with
626{
627 my $self = shift (@_);
628 my ($file, $filename, $metadata) = @_;
629
630 my $associate_ext = $self->{'associate_ext'};
631
632
633 return 0 if (!$associate_ext);
634
635 # If file, see if matches with "tie_to" doc or is one of the
636 # associated filename extensions.
637
638 my ($file_prefix,$file_ext) = ($file =~ m/^(.*)\.(.*?)$/);
639 if ((defined $file_prefix) && (defined $file_ext)) {
640
641 my $file_prefix_rec = $self->{'shared_fileroot'}->{$file_prefix};
642
643 if ($self->tie_to_filename($file_ext,$file_prefix_rec)) {
644
645 # Set up gsdlassocfile_tobe
646
647 my $exts = $file_prefix_rec->{'exts'};
648
649 if (!defined $metadata->{'gsdlassocfile_tobe'}) {
650 $metadata->{'gsdlassocfile_tobe'} = [];
651 }
652
653 my $assoc_tobe = $metadata->{'gsdlassocfile_tobe'};
654
655 my ($full_prefix) = ($filename =~ m/^(.*)\..*?$/);
656 foreach my $e (keys %$exts) {
657 my $assoc_file = "$full_prefix.$e";
658 my $mime_type = ""; # let system auto detect this
659 push(@$assoc_tobe,"$assoc_file:$mime_type:");
660 }
661 }
662 elsif ($self->tie_to_assoc_file($file_ext,$file_prefix_rec)) {
663 # a form of smart block
664
665 return 1;
666 }
667 }
668
669 return 0;
670}
671
672
673# The BasPlug read() function. This function does all the right things
674# to make general options work for a given plugin. It calls the process()
675# function which does all the work specific to a plugin (like the old
676# read functions used to do). Most plugins should define their own
677# process() function and let this read() function keep control.
678#
679# recursive plugins (e.g. RecPlug) and specialized plugins like those
680# capable of processing many documents within a single file (e.g.
681# GMLPlug) should normally implement their own version of read()
682#
683# Return number of files processed, undef if can't recognise, -1 if can't
684# process
685# Note that $base_dir might be "" and that $file might
686# include directories
687
688sub read {
689 my $self = shift (@_);
690
691 my ($pluginfo, $base_dir, $file, $metadata, $processor, $maxdocs, $total_count, $gli) = @_;
692
693 if ($self->is_recursive()) {
694 gsprintf(STDERR, "{BasPlug.read_must_be_implemented}") && die "\n";
695 }
696
697 my $outhandle = $self->{'outhandle'};
698 my $smart_block = $self->{'smart_block'};
699 my $smart_block_BN = $self->{'smart_block_BN'};
700
701 my $filename = $file;
702 $filename = &util::filename_cat ($base_dir, $file) if $base_dir =~ /\w/;
703
704 if ($self->associate_with($file,$filename,$metadata)) {
705 # a form of smart block
706 $self->{'num_blocked'} ++;
707 return 0; # blocked
708 }
709
710 if ($smart_block || $smart_block_BN) {
711
712 if (defined $self->{'file_blocks'}->{$filename} && $self->{'file_blocks'}->{$filename} == 1){
713 $self->{'num_blocked'} ++;
714 return 0; # blocked
715 }
716 } elsif ($self->{'block_exp'} ne "" && $filename =~ /$self->{'block_exp'}/) {
717 $self->{'num_blocked'} ++;
718 return 0; # blocked
719 }
720
721 if ($filename !~ /$self->{'process_exp'}/ || !-f $filename) {
722 return undef; # can't recognise
723 }
724 $file =~ s/^[\/\\]+//; # $file often begins with / so we'll tidy it up
725
726 # Do encoding stuff
727 my ($language, $encoding) = $self->textcat_get_language_encoding ($filename);
728
729 # create a new document
730 my $doc_obj = new doc ($filename, "indexed_doc");
731 $doc_obj->set_OIDtype ($processor->{'OIDtype'});
732 $doc_obj->add_utf8_metadata($doc_obj->get_top_section(), "Language", $language);
733 $doc_obj->add_utf8_metadata($doc_obj->get_top_section(), "Encoding", $encoding);
734 $doc_obj->add_utf8_metadata($doc_obj->get_top_section(), "Plugin", "$self->{'plugin_type'}");
735 $doc_obj->add_utf8_metadata($doc_obj->get_top_section(), "FileSize", (-s $filename));
736
737 my ($filemeta) = $file =~ /([^\\\/]+)$/;
738 # how do we know what encoding the filename is in?
739 $doc_obj->add_metadata($doc_obj->get_top_section(), "Source", &ghtml::dmsafe($filemeta));
740 if ($self->{'cover_image'}) {
741 $self->associate_cover_image($doc_obj, $filename);
742 }
743
744 # read in file ($text will be in utf8)
745 my $text = "";
746 $self->read_file ($filename, $encoding, $language, \$text);
747
748 if (!length ($text)) {
749 my $plugin_name = ref ($self);
750 if ($gli) {
751 print STDERR "<ProcessingError n='$file' r='File contains no text'>\n";
752 }
753 gsprintf($outhandle, "$plugin_name: {BasPlug.file_has_no_text}\n", $filename) if $self->{'verbosity'};
754
755 my $failhandle = $self->{'failhandle'};
756 gsprintf($failhandle, "$file: " . ref($self) . ": {BasPlug.empty_file}\n");
757 # print $failhandle "$file: " . ref($self) . ": file contains no text\n";
758 $self->{'num_not_processed'} ++;
759
760 return 0; # what should we return here?? error but don't want to pass it on
761 }
762
763 # include any metadata passed in from previous plugins
764 # note that this metadata is associated with the top level section
765
766 $self->extra_metadata ($doc_obj, $doc_obj->get_top_section(), $metadata);
767
768 # do plugin specific processing of doc_obj
769 unless (defined ($self->process (\$text, $pluginfo, $base_dir, $file, $metadata, $doc_obj, $gli))) {
770 $text = '';
771 undef $text;
772 print STDERR "<ProcessingError n='$file'>\n" if ($gli);
773 return -1;
774 }
775 $text='';
776 undef $text;
777
778 # do any automatic metadata extraction
779 $self->auto_extract_metadata ($doc_obj);
780
781 # add an OID
782 # see if there is a plugin-specific set_OID function...
783 if (defined ($self->can('set_OID'))) {
784 # it will need $doc_obj to set the Identifier metadata...
785 $self->set_OID($doc_obj);
786 } else {
787 # use the default set_OID() in doc.pm
788 $doc_obj->set_OID();
789 }
790
791 # process the document
792 $processor->process($doc_obj);
793
794 if(defined($self->{'places_filename'})){
795 &util::rm($self->{'places_filename'});
796 $self->{'places_filename'} = undef;
797 }
798
799 $self->{'num_processed'} ++;
800 undef $doc_obj;
801 return 1; # processed the file
802}
803
804# returns undef if file is rejected by the plugin
805sub process {
806 my $self = shift (@_);
807 my ($textref, $pluginfo, $base_dir, $file, $metadata, $doc_obj) = @_;
808
809 gsprintf(STDERR, "BasPlug::process {common.must_be_implemented}\n") && die "\n";
810 # die "Basplug::process function must be implemented in sub-class\n";
811
812 return undef; # never gets here
813}
814
815# uses the multiread package to read in the entire file pointed to
816# by filename and loads the resulting text into $$textref. Input text
817# may be in any of the encodings handled by multiread, output text
818# will be in utf8
819sub read_file {
820 my $self = shift (@_);
821 my ($filename, $encoding, $language, $textref) = @_;
822
823 if (!-r $filename)
824 {
825 my $outhandle = $self->{'outhandle'};
826 gsprintf($outhandle, "{BasPlug.read_denied}\n", $filename) if $self->{'verbosity'};
827 # print $outhandle "Read permission denied for $filename\n" if $self->{'verbosity'};
828 return;
829 }
830
831 $$textref = "";
832
833 if (!open (FILE, $filename)) {
834 gsprintf(STDERR, "BasPlug::read_file {BasPlug.could_not_open_for_reading} ($!)\n", $filename);
835 die "\n";
836 }
837
838 if ($encoding eq "ascii") {
839 undef $/;
840 $$textref = <FILE>;
841 $/ = "\n";
842 } else {
843 my $reader = new multiread();
844 $reader->set_handle ('BasPlug::FILE');
845 $reader->set_encoding ($encoding);
846 $reader->read_file ($textref);
847
848 #Now segments chinese if the separate_cjk option is set
849 if ($self->{'separate_cjk'}) {
850 # segment the Chinese words
851 $$textref = &cnseg::segment($$textref);
852 }
853 }
854
855 close FILE;
856}
857
858sub filename_based_title
859{
860 my $self = shift (@_);
861 my ($file) = @_;
862
863 my $file_derived_title = $file;
864 $file_derived_title =~ s/_/ /g;
865 $file_derived_title =~ s/\..*?$//;
866
867 return $file_derived_title;
868}
869
870
871sub title_fallback
872{
873 my $self = shift (@_);
874 my ($doc_obj,$section,$file) = @_;
875
876 if (!defined $doc_obj->get_metadata_element ($section, "Title")) {
877
878 my $file_derived_title = $self->filename_based_title($file);
879 $doc_obj->add_metadata ($section, "Title", $file_derived_title);
880 }
881}
882
883sub textcat_get_language_encoding {
884 my $self = shift (@_);
885 my ($filename) = @_;
886
887 my ($language, $encoding, $extracted_encoding);
888 if ($self->{'input_encoding'} eq "auto") {
889 # use textcat to automatically work out the input encoding and language
890 ($language, $encoding) = $self->get_language_encoding ($filename);
891 } elsif ($self->{'extract_language'}) {
892 # use textcat to get language metadata
893 ($language, $extracted_encoding) = $self->get_language_encoding ($filename);
894 $encoding = $self->{'input_encoding'};
895 # don't print this message for english... english in utf8 is identical
896 # to english in iso-8859-1 (except for some punctuation). We don't have
897 # a language model for en_utf8, so textcat always says iso-8859-1!
898 if ($extracted_encoding ne $encoding && $language ne "en"
899 && $self->{'verbosity'}) {
900 my $plugin_name = ref ($self);
901 my $outhandle = $self->{'outhandle'};
902 gsprintf($outhandle, "$plugin_name: {BasPlug.wrong_encoding}\n", $filename, $encoding, $extracted_encoding);
903 # print $outhandle "$plugin_name: WARNING: $filename was read using $encoding encoding but ";
904 # print $outhandle "appears to be encoded as $extracted_encoding.\n";
905 }
906 } else {
907 $language = $self->{'default_language'};
908 $encoding = $self->{'input_encoding'};
909 }
910 return ($language, $encoding);
911}
912
913# Uses textcat to work out the encoding and language of the text in
914# $filename. All html tags are removed before processing.
915# returns an array containing "language" and "encoding"
916sub get_language_encoding {
917 my $self = shift (@_);
918 my ($filename) = @_;
919 my $outhandle = $self->{'outhandle'};
920 my $unicode_format = "";
921 # read in file
922 open (FILE, $filename) || (gsprintf(STDERR, "BasPlug::get_language_encoding {BasPlug.could_not_open_for_reading} ($!)\n", $filename) && die "\n"); # die "BasPlug::get_language_encoding could not open $filename for reading ($!)\n";
923 undef $/;
924 my $text = <FILE>;
925 $/ = "\n";
926 close FILE;
927
928 # check if first few bytes have a Byte Order Marker
929 my $bom=substr($text,0,2); # check 16bit unicode
930 if ($bom eq "\xff\xfe") { # little endian 16bit unicode
931 $unicode_format="unicode";
932 } elsif ($bom eq "\xfe\xff") { # big endian 16bit unicode
933 $unicode_format="unicode";
934 } else {
935 $bom=substr($text,0,3); # check utf-8
936 if ($bom eq "\xef\xbb\xbf") { # utf-8 coded FEFF bom
937 $unicode_format="utf8";
938# } elsif ($bom eq "\xef\xbf\xbe") { # utf-8 coded FFFE bom. Error!?
939# $unicode_format="utf8";
940 }
941 }
942
943
944 # remove <title>stuff</title> -- as titles tend often to be in English
945 # for foreign language documents
946 $text =~ s/<title>(.|\n)*?<\/title>//i;
947
948 # remove all HTML tags
949 # XXX this doesn't match plugins derived from HTMLPlug (except ConvertTo)
950 if (ref($self) eq 'HTMLPlug' ||
951 (exists $self->{'converted_to'} && $self->{'converted_to'} eq 'HTML')){
952 $text =~ s/<[^>]*>//sg;
953 }
954
955 # get the language/encoding
956 my $results = $self->{'textcat'}->classify(\$text);
957
958 # if textcat returns 3 or less possibilities we'll use the
959 # first one in the list - otherwise use the defaults
960 if (scalar @$results > 3) {
961 my $best_encoding="";
962 if ($unicode_format) { # in case the first had a BOM
963 $best_encoding=$unicode_format;
964 } else {
965 my %guessed_encodings = ();
966 foreach my $result (@$results) {
967 $result =~ /([^\-]+)$/;
968 my $enc=$1;
969 if (!defined($guessed_encodings{$enc})) {
970 $guessed_encodings{$enc}=0;
971 }
972 $guessed_encodings{$enc}++;
973 }
974
975 $guessed_encodings{""}=-1; # for default best_encoding of ""
976 foreach my $enc (keys %guessed_encodings) {
977 if ($guessed_encodings{$enc} >
978 $guessed_encodings{$best_encoding}){
979 $best_encoding=$enc;
980 }
981 }
982 }
983
984 if ($self->{'input_encoding'} ne 'auto') {
985 if ($self->{'extract_language'} && ($self->{'verbosity'}>2)) {
986 gsprintf($outhandle,
987 "BasPlug: {BasPlug.could_not_extract_language}\n",
988 $filename, $self->{'default_language'});
989 }
990 return ($self->{'default_language'}, $self->{'input_encoding'});
991
992 } else {
993 if ($self->{'verbosity'}>2) {
994 gsprintf($outhandle,
995 "BasPlug: {BasPlug.could_not_extract_language}\n",
996 $filename, $self->{'default_language'});
997 }
998 return ($self->{'default_language'}, $best_encoding);
999 }
1000 }
1001
1002 # format language/encoding
1003 my ($language, $encoding) = $results->[0] =~ /^([^-]*)(?:-(.*))?$/;
1004 if (!defined $language) {
1005 if ($self->{'verbosity'}>2) {
1006 gsprintf($outhandle,
1007 "BasPlug: {BasPlug.could_not_extract_language}\n",
1008 $filename, $self->{'default_language'});
1009 }
1010 $language = $self->{'default_language'};
1011 }
1012 if (!defined $encoding) {
1013 if ($self->{'verbosity'}>2) {
1014 gsprintf($outhandle,
1015 "BasPlug: {BasPlug.could_not_extract_encoding}\n",
1016 $filename, $self->{'default_encoding'});
1017 }
1018 $encoding = $self->{'default_encoding'};
1019 }
1020
1021
1022 # check for equivalents where textcat doesn't have some encodings...
1023 # eg MS versions of standard encodings
1024 if ($encoding =~ /^iso_8859_(\d+)/) {
1025 my $iso = $1; # which variant of the iso standard?
1026 # iso-8859 sets don't use chars 0x80-0x9f, windows codepages do
1027 if ($text =~ /[\x80-\x9f]/) {
1028 # Western Europe
1029 if ($iso == 1 or $iso == 15) { $encoding = 'windows_1252' }
1030 elsif ($iso == 2) { $encoding = 'windows_1250' } # Central Europe
1031 elsif ($iso == 5) { $encoding = 'windows_1251' } # Cyrillic
1032 elsif ($iso == 6) { $encoding = 'windows_1256' } # Arabic
1033 elsif ($iso == 7) { $encoding = 'windows_1253' } # Greek
1034 elsif ($iso == 8) { $encoding = 'windows_1255' } # Hebrew
1035 elsif ($iso == 9) { $encoding = 'windows_1254' } # Turkish
1036 }
1037 }
1038
1039 if ($encoding !~ /^(ascii|utf8|unicode)$/ &&
1040 !defined $encodings::encodings->{$encoding}) {
1041 if ($self->{'verbosity'}) {
1042 gsprintf($outhandle, "BasPlug: {BasPlug.unsupported_encoding}\n",
1043 $filename, $encoding, $self->{'default_encoding'});
1044 }
1045 $encoding = $self->{'default_encoding'};
1046 }
1047
1048 return ($language, $encoding);
1049}
1050
1051# add any extra metadata that's been passed around from one
1052# plugin to another.
1053# extra_metadata uses add_utf8_metadata so it expects metadata values
1054# to already be in utf8
1055sub extra_metadata {
1056 my $self = shift (@_);
1057 my ($doc_obj, $cursection, $metadata) = @_;
1058
1059 foreach my $field (keys(%$metadata)) {
1060 # $metadata->{$field} may be an array reference
1061 if ($field eq "gsdlassocfile_tobe") {
1062 # 'gsdlassocfile_tobe' is artificially introduced metadata
1063 # that is used to signal that certain additional files should
1064 # be tied to this document. Useful in situations where a
1065 # metadata pass in the plugin pipeline works out some files
1066 # need to be associated with a document, but the document hasn't
1067 # been formed yet.
1068
1069 my $equiv_form = "";
1070 foreach my $gaf (@{$metadata->{$field}}) {
1071 my ($full_filename,$mimetype) = ($gaf =~ m/^(.*):(.*):$/);
1072 my ($tail_filename) = ($full_filename =~ /^.*[\/\\](.+?)$/);
1073 my $filename = $full_filename;
1074
1075 $doc_obj->associate_file($full_filename,$tail_filename,$mimetype);
1076
1077 my ($doc_ext) = ($tail_filename =~ m/^.*\.(.*)$/);
1078 my $start_doclink = "<a href=\"_httpcollection_/index/assoc/{Or}{[parent(Top):archivedir],[archivedir]}/$tail_filename\">";
1079 my $srcicon = "_icon".$doc_ext."_";
1080 my $end_doclink = "</a>";
1081
1082 $equiv_form .= " $start_doclink\{If\}{$srcicon,$srcicon,$doc_ext\}$end_doclink";
1083 }
1084 $doc_obj->add_utf8_metadata ($cursection, "equivlink", $equiv_form);
1085 }
1086 elsif (ref ($metadata->{$field}) eq "ARRAY") {
1087 map {
1088 $doc_obj->add_utf8_metadata ($cursection, $field, $_);
1089 } @{$metadata->{$field}};
1090 } else {
1091 $doc_obj->add_utf8_metadata ($cursection, $field, $metadata->{$field});
1092 }
1093 }
1094}
1095
1096# initialise metadata extractors
1097sub initialise_extractors {
1098 my $self = shift (@_);
1099
1100 if ($self->{'extract_acronyms'} || $self->{'markup_acronyms'}) {
1101 &acronym::initialise_acronyms();
1102 }
1103}
1104
1105# finalise metadata extractors
1106sub finalise_extractors {
1107 my $self = shift (@_);
1108
1109 if ($self->{'extract_acronyms'} || $self->{'markup_acronyms'}) {
1110 &acronym::finalise_acronyms();
1111 }
1112}
1113
1114# FIRSTNNN: extract the first NNN characters as metadata
1115sub extract_first_NNNN_characters {
1116 my $self = shift (@_);
1117 my ($textref, $doc_obj, $thissection) = @_;
1118
1119 foreach my $size (split /,/, $self->{'first'}) {
1120 my $tmptext = $$textref;
1121 $tmptext =~ s/^\s+//;
1122 $tmptext =~ s/\s+$//;
1123 $tmptext =~ s/\s+/ /gs;
1124 $tmptext = substr ($tmptext, 0, $size);
1125 $tmptext =~ s/\s\S*$/&#8230;/;
1126 $doc_obj->add_utf8_metadata ($thissection, "First$size", $tmptext);
1127 }
1128}
1129
1130sub extract_email {
1131 my $self = shift (@_);
1132 my ($textref, $doc_obj, $thissection) = @_;
1133 my $outhandle = $self->{'outhandle'};
1134
1135 gsprintf($outhandle, " {BasPlug.extracting_emails}...\n")
1136 if ($self->{'verbosity'} > 2);
1137
1138 my @email = ($$textref =~ m/([-a-z0-9\.@+_=]+@(?:[-a-z0-9]+\.)+(?:com|org|edu|mil|int|net|[a-z][a-z]))/g);
1139 @email = sort @email;
1140
1141# if($self->{"new_extract_email"} == 0)
1142# {
1143# my @email2 = ();
1144# foreach my $address (@email)
1145# {
1146# if (!(join(" ",@email2) =~ m/(^| )$address( |$)/ ))
1147# {
1148# push @email2, $address;
1149# $doc_obj->add_utf8_metadata ($thissection, "emailAddress", $address);
1150# # print $outhandle " extracting $address\n"
1151# &gsprintf($outhandle, " {BasPlug.extracting} $address\n")
1152# if ($self->{'verbosity'} > 3);
1153# }
1154# }
1155# }
1156# else
1157# {
1158 my $hashExistMail = {};
1159 foreach my $address (@email) {
1160 if (!(defined $hashExistMail->{$address}))
1161 {
1162 $hashExistMail->{$address} = 1;
1163 $doc_obj->add_utf8_metadata ($thissection, "emailAddress", $address);
1164 gsprintf($outhandle, " {BasPlug.extracting} $address\n")
1165 if ($self->{'verbosity'} > 3);
1166 }
1167 }
1168 gsprintf($outhandle, " {BasPlug.done_email_extract}\n")
1169 if ($self->{'verbosity'} > 2);
1170}
1171
1172# extract metadata
1173sub auto_extract_metadata {
1174
1175 my $self = shift (@_);
1176 my ($doc_obj) = @_;
1177
1178 if ($self->{'extract_email'}) {
1179 my $thissection = $doc_obj->get_top_section();
1180 while (defined $thissection) {
1181 my $text = $doc_obj->get_text($thissection);
1182 $self->extract_email (\$text, $doc_obj, $thissection) if $text =~ /./;
1183 $thissection = $doc_obj->get_next_section ($thissection);
1184 }
1185 }
1186 if ($self->{'extract_placenames'}) {
1187 my $thissection = $doc_obj->get_top_section();
1188 while (defined $thissection) {
1189 my $text = $doc_obj->get_text($thissection);
1190 $self->extract_placenames (\$text, $doc_obj, $thissection) if $text =~ /./;
1191 $thissection = $doc_obj->get_next_section ($thissection);
1192 }
1193 }
1194
1195 #adding kea keyphrases
1196 if ($self->{'extract_keyphrases'}) {
1197
1198 my $thissection = $doc_obj->get_top_section();
1199 my $text = "";
1200 my $list;
1201
1202 #loop through sections to gather whole doc
1203 while (defined $thissection) {
1204 my $sectiontext = $doc_obj->get_text($thissection);
1205 $text = $text.$sectiontext;
1206 $thissection = $doc_obj->get_next_section ($thissection);
1207 }
1208
1209 if($self->{'extract_keyphrase_options'}) { #if kea options flag is set, call Kea with specified options
1210 $list = &Kea::extract_KeyPhrases ($text, $self->{'extract_keyphrase_options'});
1211 } else { #otherwise call Kea with no options
1212 $list = &Kea::extract_KeyPhrases ($text);
1213 }
1214
1215 if ($list){
1216 # if a list of kea keyphrases was returned (ie not empty)
1217 if ($self->{'verbosity'}) {
1218 gsprintf(STDERR, "{BasPlug.keyphrases}: $list\n");
1219 }
1220
1221 #add metadata to top section
1222 $thissection = $doc_obj->get_top_section();
1223
1224 # add all key phrases as one metadata
1225 $doc_obj->add_metadata($thissection, "Keyphrases", $list);
1226
1227 # add individual key phrases as multiple metadata
1228 foreach my $keyphrase (split(',', $list)) {
1229 $keyphrase =~ s/^\s+|\s+$//g;
1230 $doc_obj->add_metadata($thissection, "Keyphrase", $keyphrase);
1231 }
1232 }
1233 } #end of kea
1234
1235 if ($self->{'first'}) {
1236 my $thissection = $doc_obj->get_top_section();
1237 while (defined $thissection) {
1238 my $text = $doc_obj->get_text($thissection);
1239 $self->extract_first_NNNN_characters (\$text, $doc_obj, $thissection) if $text =~ /./;
1240 $thissection = $doc_obj->get_next_section ($thissection);
1241 }
1242 }
1243
1244 if ($self->{'extract_acronyms'}) {
1245 my $thissection = $doc_obj->get_top_section();
1246 while (defined $thissection) {
1247 my $text = $doc_obj->get_text($thissection);
1248 $self->extract_acronyms (\$text, $doc_obj, $thissection) if $text =~ /./;
1249 $thissection = $doc_obj->get_next_section ($thissection);
1250 }
1251 }
1252
1253 if ($self->{'markup_acronyms'}) {
1254 my $thissection = $doc_obj->get_top_section();
1255 while (defined $thissection) {
1256 my $text = $doc_obj->get_text($thissection);
1257 $text = $self->markup_acronyms ($text, $doc_obj, $thissection);
1258 $doc_obj->delete_text($thissection);
1259 $doc_obj->add_text($thissection, $text);
1260 $thissection = $doc_obj->get_next_section ($thissection);
1261 }
1262 }
1263
1264 if($self->{'extract_historical_years'}) {
1265 my $thissection = $doc_obj->get_top_section();
1266 while (defined $thissection) {
1267
1268 my $text = $doc_obj->get_text($thissection);
1269 &DateExtract::get_date_metadata($text, $doc_obj,
1270 $thissection,
1271 $self->{'no_bibliography'},
1272 $self->{'maximum_year'},
1273 $self->{'maximum_century'});
1274 $thissection = $doc_obj->get_next_section ($thissection);
1275 }
1276 }
1277}
1278
1279# extract acronyms from a section in a document. progress is
1280# reported to outhandle based on the verbosity. both the Acronym
1281# and the AcronymKWIC metadata items are created.
1282
1283sub extract_acronyms {
1284 my $self = shift (@_);
1285 my ($textref, $doc_obj, $thissection) = @_;
1286 my $outhandle = $self->{'outhandle'};
1287
1288 # print $outhandle " extracting acronyms ...\n"
1289 gsprintf($outhandle, " {BasPlug.extracting_acronyms}...\n")
1290 if ($self->{'verbosity'} > 2);
1291
1292 my $acro_array = &acronym::acronyms($textref);
1293
1294 foreach my $acro (@$acro_array) {
1295
1296 #check that this is the first time ...
1297 my $seen_before = "false";
1298 my $previous_data = $doc_obj->get_metadata($thissection, "Acronym");
1299 foreach my $thisAcro (@$previous_data) {
1300 if ($thisAcro eq $acro->to_string()) {
1301 $seen_before = "true";
1302 if ($self->{'verbosity'} >= 4) {
1303 gsprintf($outhandle, " {BasPlug.already_seen} " .
1304 $acro->to_string() . "\n");
1305 }
1306 }
1307 }
1308
1309 if ($seen_before eq "false") {
1310 #write it to the file ...
1311 $acro->write_to_file();
1312
1313 #do the normal acronym
1314 $doc_obj->add_utf8_metadata($thissection, "Acronym", $acro->to_string());
1315 gsprintf($outhandle, " {BasPlug.adding} ".$acro->to_string()."\n")
1316 if ($self->{'verbosity'} > 3);
1317 }
1318 }
1319
1320 gsprintf($outhandle, " {BasPlug.done_acronym_extract}\n")
1321 if ($self->{'verbosity'} > 2);
1322}
1323
1324sub markup_acronyms {
1325 my $self = shift (@_);
1326 my ($text, $doc_obj, $thissection) = @_;
1327 my $outhandle = $self->{'outhandle'};
1328
1329 gsprintf($outhandle, " {BasPlug.marking_up_acronyms}...\n")
1330 if ($self->{'verbosity'} > 2);
1331
1332 #self is passed in to check for verbosity ...
1333 $text = &acronym::markup_acronyms($text, $self);
1334
1335 gsprintf($outhandle, " {BasPlug.done_acronym_markup}\n")
1336 if ($self->{'verbosity'} > 2);
1337
1338 return $text;
1339}
1340
1341sub compile_stats {
1342 my $self = shift(@_);
1343 my ($stats) = @_;
1344
1345 $stats->{'num_processed'} += $self->{'num_processed'};
1346 $stats->{'num_not_processed'} += $self->{'num_not_processed'};
1347 $stats->{'num_archives'} += $self->{'num_archives'};
1348
1349}
1350
1351sub associate_cover_image {
1352 my $self = shift(@_);
1353 my ($doc_obj, $filename) = @_;
1354
1355 my $top_section=$doc_obj->get_top_section();
1356
1357 $filename =~ s/\.[^\\\/\.]+$/\.jpg/;
1358 if (-e $filename) {
1359 $doc_obj->associate_file($filename, "cover.jpg", "image/jpeg");
1360 $doc_obj->add_utf8_metadata($top_section, "hascover", 1);
1361 } else {
1362 $filename =~ s/jpg$/JPG/;
1363 if (-e $filename) {
1364 $doc_obj->associate_file($filename, "cover.jpg", "image/jpeg");
1365 $doc_obj->add_utf8_metadata($top_section, "hascover", 1);
1366 }
1367 }
1368}
1369
13701;
Note: See TracBrowser for help on using the repository browser.