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

Last change on this file since 15115 was 15115, checked in by ak19, 16 years ago

Added SourceReplaceable in output for plugin xml. srcreplaceable is a new option to work new script replace_srcdoc_with_html.pl
  • Property svn:keywords set to Author Date Id Revision
File size: 49.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;
39no strict 'subs';
40no strict 'refs'; # allow filehandles to be variables and viceversa
41
42use File::Basename;
43
44use Kea;
45use multiread;
46use encodings;
47use unicode;
48use cnseg;
49use acronym;
50use textcat;
51use doc;
52eval "require diagnostics"; # some perl distros (eg mac) don't have this
53use DateExtract;
54use ghtml;
55use gsprintf 'gsprintf';
56use printusage;
57use parse2;
58
59
60use GISBasPlug;
61
62@BasPlug::ISA = ( GISBasPlug );
63
64my $unicode_list =
65 [ { 'name' => "ascii",
66 'desc' => "{BasPlug.input_encoding.ascii}" },
67 { 'name' => "utf8",
68 'desc' => "{BasPlug.input_encoding.utf8}" },
69 { 'name' => "unicode",
70 'desc' => "{BasPlug.input_encoding.unicode}" } ];
71
72my $auto_unicode_list =
73 [ { 'name' => "auto",
74 'desc' => "{BasPlug.input_encoding.auto}" } ];
75
76my $e = $encodings::encodings;
77foreach my $enc (sort {$e->{$a}->{'name'} cmp $e->{$b}->{'name'}} keys (%$e))
78{
79 my $hashEncode =
80 {'name' => $enc,
81 'desc' => $e->{$enc}->{'name'}};
82
83 push(@{$unicode_list},$hashEncode);
84}
85
86push(@{$auto_unicode_list},@{$unicode_list});
87
88my $arguments =
89 [ { 'name' => "process_exp",
90 'desc' => "{BasPlug.process_exp}",
91 'type' => "regexp",
92 'deft' => "",
93 'reqd' => "no" },
94 { 'name' => "block_exp",
95 'desc' => "{BasPlug.block_exp}",
96 'type' => "regexp",
97 'deft' => "",
98 'reqd' => "no" },
99 { 'name' => "smart_block",
100 'desc' => "{BasPlug.smart_block}",
101 'type' => "flag",
102 'reqd' => "no" },
103 { 'name' => "associate_ext",
104 'desc' => "{BasPlug.associate_ext}",
105 'type' => "string",
106 'reqd' => "no" },
107 { 'name' => "associate_tail_re",
108 'desc' => "{BasPlug.associate_tail_re}",
109 'type' => "string",
110 'reqd' => "no" },
111 { 'name' => "use_as_doc_identifier",
112 'desc' => "{BasPlug.use_as_doc_identifier}",
113 'type' => "string",
114 'reqd' => "no" ,
115 'deft' => "" } ,
116 { 'name' => "input_encoding",
117 'desc' => "{BasPlug.input_encoding}",
118 'type' => "enum",
119 'list' => $auto_unicode_list,
120 'reqd' => "no" ,
121 'deft' => "auto" } ,
122 { 'name' => "default_encoding",
123 'desc' => "{BasPlug.default_encoding}",
124 'type' => "enum",
125 'list' => $unicode_list,
126 'reqd' => "no",
127 'deft' => "utf8" },
128 { 'name' => "extract_language",
129 'desc' => "{BasPlug.extract_language}",
130 'type' => "flag",
131 'reqd' => "no" },
132 { 'name' => "default_language",
133 'desc' => "{BasPlug.default_language}",
134 'type' => "string",
135 'deft' => "en",
136 'reqd' => "no" },
137 { 'name' => "extract_acronyms",
138 'desc' => "{BasPlug.extract_acronyms}",
139 'type' => "flag",
140 'reqd' => "no" },
141 { 'name' => "markup_acronyms",
142 'desc' => "{BasPlug.markup_acronyms}",
143 'type' => "flag",
144 'reqd' => "no" },
145 { 'name' => "extract_keyphrases",
146 'desc' => "{BasPlug.extract_keyphrases}",
147 'type' => "flag",
148 'reqd' => "no" },
149 { 'name' => "extract_keyphrases_kea4",
150 'desc' => "{BasPlug.extract_keyphrases_kea4}",
151 'type' => "flag",
152 'reqd' => "no" },
153 { 'name' => "extract_keyphrase_options",
154 'desc' => "{BasPlug.extract_keyphrase_options}",
155 'type' => "string",
156 'deft' => "",
157 'reqd' => "no" },
158 { 'name' => "first",
159 'desc' => "{BasPlug.first}",
160 'type' => "string",
161 'reqd' => "no" },
162 { 'name' => "extract_email",
163 'desc' => "{BasPlug.extract_email}",
164 'type' => "flag",
165 'reqd' => "no" },
166 { 'name' => "extract_historical_years",
167 'desc' => "{BasPlug.extract_historical_years}",
168 'type' => "flag",
169 'reqd' => "no" },
170 { 'name' => "maximum_year",
171 'desc' => "{BasPlug.maximum_year}",
172 'type' => "int",
173 'deft' => (localtime)[5]+1900,
174 'char_length' => "4",
175 #'range' => "2,100",
176 'reqd' => "no"},
177 { 'name' => "maximum_century",
178 'desc' => "{BasPlug.maximum_century}",
179 'type' => "string",
180 'deft' => "-1",
181 'reqd' => "no" },
182 { 'name' => "no_bibliography",
183 'desc' => "{BasPlug.no_bibliography}",
184 'type' => "flag",
185 'reqd' => "no"},
186 { 'name' => "no_cover_image",
187 'desc' => "{BasPlug.no_cover_image}",
188 'type' => "flag",
189 'reqd' => "no" },
190 { 'name' => "separate_cjk",
191 'desc' => "{BasPlug.separate_cjk}",
192 'type' => "flag",
193 'reqd' => "no",
194 'hiddengli' => "yes" },
195 { 'name' => "new_extract_email",
196 'desc' => "",
197 'type' => "flag",
198 'reqd' => "no",
199 'hiddengli' => "yes" } ];
200
201my $gis_arguments =
202 [ { 'name' => "extract_placenames",
203 'desc' => "{GISBasPlug.extract_placenames}",
204 'type' => "flag",
205 'reqd' => "no" },
206 { 'name' => "gazetteer",
207 'desc' => "{GISBasPlug.gazetteer}",
208 'type' => "string",
209 'reqd' => "no" },
210 { 'name' => "place_list",
211 'desc' => "{GISBasPlug.place_list}",
212 'type' => "flag",
213 'reqd' => "no" } ];
214
215
216my $options = { 'name' => "BasPlug",
217 'desc' => "{BasPlug.desc}",
218 'abstract' => "yes",
219 'inherits' => "no",
220 'args' => $arguments };
221
222
223sub set_incremental {
224 my $self = shift(@_);
225 my ($incremental) = @_;
226
227 $self->{'incremental'} = $incremental;
228}
229
230sub get_arguments
231{
232 my $self = shift(@_);
233 my $optionlistref = $self->{'option_list'};
234 my @optionlist = @$optionlistref;
235 my $pluginoptions = pop(@$optionlistref);
236 my $pluginarguments = $pluginoptions->{'args'};
237 return $pluginarguments;
238}
239
240
241sub print_xml_usage
242{
243 my $self = shift(@_);
244 my $header = shift(@_);
245 my $high_level_information_only = shift(@_);
246
247 # XML output is always in UTF-8
248 gsprintf::output_strings_in_UTF8;
249
250 if ($header) {
251 &PrintUsage::print_xml_header("plugin");
252 }
253 $self->print_xml($high_level_information_only);
254}
255
256
257sub print_xml
258{
259 my $self = shift(@_);
260 my $high_level_information_only = shift(@_);
261
262 my $optionlistref = $self->{'option_list'};
263 my @optionlist = @$optionlistref;
264 my $pluginoptions = shift(@$optionlistref);
265 return if (!defined($pluginoptions));
266
267 # Find the process and block default expressions in the plugin arguments
268 my $process_exp = "";
269 my $block_exp = "";
270 if (defined($pluginoptions->{'args'})) {
271 foreach my $option (@{$pluginoptions->{'args'}}) {
272 if ($option->{'name'} eq "process_exp") {
273 $process_exp = $option->{'deft'};
274 }
275 if ($option->{'name'} eq "block_exp") {
276 $block_exp = $option->{'deft'};
277 }
278 }
279 }
280
281 gsprintf(STDERR, "<PlugInfo>\n");
282 gsprintf(STDERR, " <Name>$pluginoptions->{'name'}</Name>\n");
283 my $desc = gsprintf::lookup_string($pluginoptions->{'desc'});
284 $desc =~ s/</&amp;lt;/g; # doubly escaped
285 $desc =~ s/>/&amp;gt;/g;
286 gsprintf(STDERR, " <Desc>$desc</Desc>\n");
287 gsprintf(STDERR, " <Abstract>$pluginoptions->{'abstract'}</Abstract>\n");
288 gsprintf(STDERR, " <Inherits>$pluginoptions->{'inherits'}</Inherits>\n");
289 gsprintf(STDERR, " <Processes>$process_exp</Processes>\n");
290 gsprintf(STDERR, " <Blocks>$block_exp</Blocks>\n");
291 gsprintf(STDERR, " <Explodes>" . ($pluginoptions->{'explodes'} || "no") . "</Explodes>\n");
292 # adding new option that works with replace_srcdoc_with_html.pl
293 gsprintf(STDERR, " <SourceReplaceable>" . ($pluginoptions->{'srcreplaceable'} || "no") . "</SourceReplaceable>\n");
294 unless (defined($high_level_information_only)) {
295 gsprintf(STDERR, " <Arguments>\n");
296 if (defined($pluginoptions->{'args'})) {
297 &PrintUsage::print_options_xml($pluginoptions->{'args'});
298 }
299 gsprintf(STDERR, " </Arguments>\n");
300
301 # Recurse up the plugin hierarchy
302 $self->print_xml();
303 }
304 gsprintf(STDERR, "</PlugInfo>\n");
305}
306
307
308sub print_txt_usage
309{
310 my $self = shift(@_);
311 # Print the usage message for a plugin (recursively)
312 my $descoffset = $self->determine_description_offset(0);
313 $self->print_plugin_usage($descoffset, 1);
314}
315
316
317sub determine_description_offset
318{
319 my $self = shift(@_);
320 my $maxoffset = shift(@_);
321
322 my $optionlistref = $self->{'option_list'};
323 my @optionlist = @$optionlistref;
324 my $pluginoptions = shift(@$optionlistref);
325 return $maxoffset if (!defined($pluginoptions));
326
327 # Find the length of the longest option string of this plugin
328 my $pluginargs = $pluginoptions->{'args'};
329 if (defined($pluginargs)) {
330 my $longest = &PrintUsage::find_longest_option_string($pluginargs);
331 if ($longest > $maxoffset) {
332 $maxoffset = $longest;
333 }
334 }
335
336 # Recurse up the plugin hierarchy
337 $maxoffset = $self->determine_description_offset($maxoffset);
338 $self->{'option_list'} = \@optionlist;
339 return $maxoffset;
340}
341
342
343sub print_plugin_usage
344{
345 my $self = shift(@_);
346 my $descoffset = shift(@_);
347 my $isleafclass = shift(@_);
348
349 my $optionlistref = $self->{'option_list'};
350 my @optionlist = @$optionlistref;
351 my $pluginoptions = shift(@$optionlistref);
352 return if (!defined($pluginoptions));
353
354 my $pluginname = $pluginoptions->{'name'};
355 my $pluginargs = $pluginoptions->{'args'};
356 my $plugindesc = $pluginoptions->{'desc'};
357
358 # Produce the usage information using the data structure above
359 if ($isleafclass) {
360 if (defined($plugindesc)) {
361 gsprintf(STDERR, "$plugindesc\n\n");
362 }
363 gsprintf(STDERR, " {common.usage}: plugin $pluginname [{common.options}]\n\n");
364 }
365
366 # Display the plugin options, if there are some
367 if (defined($pluginargs)) {
368 # Calculate the column offset of the option descriptions
369 my $optiondescoffset = $descoffset + 2; # 2 spaces between options & descriptions
370
371 if ($isleafclass) {
372 gsprintf(STDERR, " {common.specific_options}:\n");
373 }
374 else {
375 gsprintf(STDERR, " {common.general_options}:\n", $pluginname);
376 }
377
378 # Display the plugin options
379 &PrintUsage::print_options_txt($pluginargs, $optiondescoffset);
380 }
381
382 # Recurse up the plugin hierarchy
383 $self->print_plugin_usage($descoffset, 0);
384 $self->{'option_list'} = \@optionlist;
385}
386
387
388sub new {
389 # Set Encodings to the list!!
390
391
392 # Start the BasPlug Constructor
393 my $class = shift (@_);
394 my ($pluginlist,$args,$hashArgOptLists) = @_;
395 push(@$pluginlist, $class);
396 my $plugin_name = (defined $pluginlist->[0]) ? $pluginlist->[0] : $class;
397
398 if(defined $arguments){ push(@{$hashArgOptLists->{"ArgList"}},@{$arguments});}
399 if(defined $options) { push(@{$hashArgOptLists->{"OptList"}},$options)};
400
401 if (GISBasPlug::has_mapdata()) {
402 push(@$arguments,@$gis_arguments);
403 }
404
405 my $self = {};
406 $self->{'outhandle'} = STDERR;
407 $self->{'option_list'} = $hashArgOptLists->{"OptList"};
408 $self->{"info_only"} = 0;
409
410 # Check if gsdlinfo is in the argument list or not - if it is, don't parse
411 # the args, just return the object.
412 foreach my $strArg (@{$args})
413 {
414 if($strArg eq "-gsdlinfo")
415 {
416 $self->{"info_only"} = 1;
417 return bless $self, $class;
418 }
419 }
420
421 if(parse2::parse($args,$hashArgOptLists->{"ArgList"},$self) == -1)
422 {
423 my $classTempClass = bless $self, $class;
424 print STDERR "<BadPlugin p=$plugin_name>\n";
425 &gsprintf(STDERR, "\n{BasPlug.bad_general_option}\n", $plugin_name);
426 $classTempClass->print_txt_usage(""); # Use default resource bundle
427 die "\n";
428 }
429
430
431 delete $self->{"info_only"};
432 # else parsing was successful.
433
434 $self->{'plugin_type'} = $plugin_name;
435 #$self->{'outhandle'} = STDERR;
436 $self->{'num_processed'} = 0;
437 $self->{'num_not_processed'} = 0;
438 $self->{'num_blocked'} = 0;
439 $self->{'num_archives'} = 0;
440 $self->{'cover_image'} = 1; # cover image is on by default
441 $self->{'cover_image'} = 0 if ($self->{'no_cover_image'});
442 #$self->{'option_list'} = $hashArgOptLists->{"OptList"};
443
444 my $associate_ext = $self->{'associate_ext'};
445 if ((defined $associate_ext) && ($associate_ext ne "")) {
446
447 my $associate_tail_re = $self->{'associate_tail_re'};
448 if ((defined $associate_tail_re) && ($associate_tail_re ne "")) {
449 my $outhandle = $self->{'outhandle'};
450 print $outhandle "Warning: can only specify 'associate_ext' or 'associate_tail_re'\n";
451 print $outhandle " defaulting to 'associate_tail_re'\n";
452 }
453 else {
454 my @exts = split(/,/,$associate_ext);
455
456 my @exts_bracketed = map { $_ = "(?:\\.$_)" } @exts;
457 my $associate_tail_re = join("|",@exts_bracketed);
458 $self->{'associate_tail_re'} = $associate_tail_re;
459 }
460
461 delete $self->{'associate_ext'};
462 }
463
464 $self->{'shared_fileroot'} = {};
465 $self->{'file_blocks'} = {};
466
467 if ($self->{'extract_placenames'}) {
468
469 my $outhandle = $self->{'outhandle'};
470
471 my $places_ref
472 = GISBasPlug::loadGISDatabase($outhandle,$self->{'gazetteer'});
473
474 if (!defined $places_ref) {
475 print $outhandle "Warning: Error loading mapdata gazetteer \"$self->{'gazetteer'}\"\n";
476 print $outhandle " No placename extraction will take place.\n";
477 $self->{'extract_placenames'} = undef;
478 }
479 else {
480 $self->{'places'} = $places_ref;
481 }
482 }
483
484 return bless $self, $class;
485
486}
487
488# initialize BasPlug options
489# if init() is overridden in a sub-class, remember to call BasPlug::init()
490sub init {
491 my $self = shift (@_);
492 my ($verbosity, $outhandle, $failhandle) = @_;
493
494 # verbosity is passed through from the processor
495 $self->{'verbosity'} = $verbosity;
496
497 # as are the outhandle and failhandle
498 $self->{'outhandle'} = $outhandle if defined $outhandle;
499 $self->{'failhandle'} = $failhandle;
500
501 # set process_exp and block_exp to defaults unless they were
502 # explicitly set
503
504 if ((!$self->is_recursive()) and
505 (!defined $self->{'process_exp'}) || ($self->{'process_exp'} eq "")) {
506
507 $self->{'process_exp'} = $self->get_default_process_exp ();
508 if ($self->{'process_exp'} eq "") {
509 warn ref($self) . " Warning: Non-recursive plugin has no process_exp\n";
510 }
511 }
512
513 if ((!defined $self->{'block_exp'}) || ($self->{'block_exp'} eq "")) {
514 $self->{'block_exp'} = $self->get_default_block_exp ();
515 }
516
517}
518
519sub begin {
520 my $self = shift (@_);
521 my ($pluginfo, $base_dir, $processor, $maxdocs) = @_;
522
523 #my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(0);
524 #print STDERR "Calling method; $cfilename:$cline $cpackage->$csubr\n";
525
526 $self->initialise_extractors();
527}
528
529sub end {
530 # potentially called at the end of each plugin pass
531 # import.pl only has one plugin pass, but buildcol.pl has multiple ones
532
533 my ($self) = @_;
534 $self->finalise_extractors();
535}
536
537sub deinit {
538 # called only once, after all plugin passes have been done
539
540 my ($self) = @_;
541}
542
543# this function should be overridden to return 1
544# in recursive plugins
545sub is_recursive {
546 my $self = shift (@_);
547
548 return 0;
549}
550
551sub get_default_block_exp {
552 my $self = shift (@_);
553
554 return "";
555}
556
557sub get_default_process_exp {
558 my $self = shift (@_);
559
560 return "";
561}
562
563# default implementation is to do nothing.
564sub store_block_files
565{
566 my $self =shift (@_);
567 my ($filename) = @_;
568 return;
569}
570
571#default implementation is to block a file with same name as this, but extension jpg or JPG, if cover_images is on.
572sub block_cover_image
573{
574 my $self =shift;
575 my $filename = shift;
576
577 if ($self->{'cover_image'}) {
578 my $coverfile = $filename;
579 $coverfile =~ s/\.[^\\\/\.]+$/\.jpg/;
580 if (!-e $coverfile) {
581 $coverfile =~ s/jpg$/JPG/;
582 }
583 if (-e $coverfile) {
584 $self->{'file_blocks'}->{$coverfile} = 1;
585 }
586 }
587
588 return;
589}
590
591sub root_ext_split
592{
593 my $self = shift (@_);
594 my ($filename,$tail_re) = @_;
595
596 my ($file_prefix,$file_ext) = ($filename =~ m/^(.*?)($tail_re)$/);
597
598 if ((!defined $file_prefix) || (!defined $file_ext)) {
599 ($file_prefix,$file_ext) = ($filename =~ m/^(.*)(\..*?)$/);
600 }
601
602 return ($file_prefix,$file_ext);
603}
604
605sub metadata_read {
606 my $self = shift (@_);
607 my ($pluginfo, $base_dir, $file, $metadata, $extrametakeys, $extrametadata, $processor, $maxdocs, $gli) = @_;
608 # Keep track of filenames with same root but different extensions
609 # Used to support -associate_ext and the more generalised
610 # -associate_tail_re
611
612 my $associate_tail_re = $self->{'associate_tail_re'};
613 if ((defined $associate_tail_re) && ($associate_tail_re ne "")) {
614
615 my ($file_prefix,$file_ext)
616 = $self->root_ext_split($file,$associate_tail_re);
617
618 if ((defined $file_prefix) && (defined $file_ext)) {
619
620 my $shared_fileroot = $self->{'shared_fileroot'};
621 if (!defined $shared_fileroot->{$file_prefix}) {
622 my $file_prefix_rec = { 'tie_to' => undef,
623 'exts' => {} };
624 $shared_fileroot->{$file_prefix} = $file_prefix_rec;
625 }
626
627 my $file_prefix_rec = $shared_fileroot->{$file_prefix};
628
629 my $process_exp = $self->{'process_exp'};
630
631 if ($file =~ m/$process_exp/) {
632 # This is the document the others should be tied to
633 $file_prefix_rec->{'tie_to'} = $file_ext;
634 }
635 else {
636 if ($file_ext =~ m/$associate_tail_re$/) {
637 $file_prefix_rec->{'exts'}->{$file_ext} = 1;
638 }
639 }
640
641 }
642 }
643
644 # now check whether we are actually processing this
645 my $filename = $file;
646 $filename = &util::filename_cat ($base_dir, $file) if $base_dir =~ /\w/;
647 if ($self->{'process_exp'} eq "" || $filename !~ /$self->{'process_exp'}/ || !-f $filename) {
648 return undef; # can't recognise
649 }
650
651 # do smart blocking if appropriate
652 if ($self->{'smart_block'}) {
653 $self->store_block_files($filename);
654 }
655 # block the cover image if there is one
656 if ($self->{'cover_image'}) {
657 $self->block_cover_image($filename);
658 }
659
660 return 1;
661}
662
663sub tie_to_filename
664{
665 my $self = shift (@_);
666
667 my ($file_ext,$file_prefix_rec) = @_;
668
669 if (defined $file_prefix_rec) {
670 my $tie_to = $file_prefix_rec->{'tie_to'};
671
672 if (defined $tie_to) {
673 if ($tie_to eq $file_ext) {
674 return 1;
675 }
676 }
677 }
678
679 return 0;
680}
681
682sub tie_to_assoc_file
683{
684 my $self = shift (@_);
685 my ($file_ext,$file_prefix_rec) = @_;
686
687 if (defined $file_prefix_rec) {
688 my $tie_to = $file_prefix_rec->{'tie_to'};
689 if (defined $tie_to) {
690
691 my $exts = $file_prefix_rec->{'exts'};
692
693 my $has_file_ext = $exts->{$file_ext};
694
695 if ($has_file_ext) {
696 return 1;
697 }
698 }
699 }
700
701 return 0;
702}
703
704
705sub associate_with
706{
707 my $self = shift (@_);
708 my ($file, $filename, $metadata) = @_;
709
710 my $associate_tail_re = $self->{'associate_tail_re'};
711 return 0 if (!$associate_tail_re);
712
713 # If file, see if matches with "tie_to" doc or is one of the
714 # associated filename extensions.
715
716 my ($file_prefix,$file_ext) = $self->root_ext_split($file,$associate_tail_re);
717
718 if ((defined $file_prefix) && (defined $file_ext)) {
719
720 my $file_prefix_rec = $self->{'shared_fileroot'}->{$file_prefix};
721
722 if ($self->tie_to_filename($file_ext,$file_prefix_rec)) {
723
724 # Set up gsdlassocfile_tobe
725
726 my $exts = $file_prefix_rec->{'exts'};
727
728 if (!defined $metadata->{'gsdlassocfile_tobe'}) {
729 $metadata->{'gsdlassocfile_tobe'} = [];
730 }
731
732 my $assoc_tobe = $metadata->{'gsdlassocfile_tobe'};
733
734 my ($full_prefix) = ($filename =~ m/^(.*)\..*?$/);
735 foreach my $e (keys %$exts) {
736 my $assoc_file = "$full_prefix$e";
737 print STDERR " $self->{'plugin_type'}: Associating $file_prefix$e with $file_prefix_rec->{'tie_to'} version\n";
738 my $mime_type = ""; # let system auto detect this
739 push(@$assoc_tobe,"$assoc_file:$mime_type:");
740 }
741
742 }
743 elsif ($self->tie_to_assoc_file($file_ext,$file_prefix_rec)) {
744
745
746 # a form of smart block
747 return 1;
748 }
749 }
750
751 return 0;
752}
753
754
755sub read_block {
756 my $self = shift (@_);
757
758 my ($pluginfo, $base_dir, $file, $metadata, $processor, $maxdocs, $total_count, $gli) = @_;
759
760
761 my $filename = $file;
762 $filename = &util::filename_cat ($base_dir, $file) if $base_dir =~ /\w/;
763
764 if ($self->associate_with($file,$filename,$metadata)) {
765 # a form of smart block
766 $self->{'num_blocked'} ++;
767 return (0,undef); # blocked
768 }
769
770 my $smart_block = $self->{'smart_block'};
771 my $smart_block_BN = $self->{'smart_block_BN'};
772
773 if ($smart_block || $smart_block_BN) {
774 if (defined $self->{'file_blocks'}->{$filename} && $self->{'file_blocks'}->{$filename} == 1){
775 $self->{'num_blocked'} ++;
776 return (0,undef); # blocked
777 }
778 } else {
779 if ($self->{'block_exp'} ne "" && $filename =~ /$self->{'block_exp'}/) {
780 $self->{'num_blocked'} ++;
781 return (0,undef); # blocked
782 }
783 if ($self->{'cover_image'}) {
784 if (defined $self->{'file_blocks'}->{$filename} && $self->{'file_blocks'}->{$filename} == 1){
785 $self->{'num_blocked'} ++;
786 return (0,undef); # blocked
787 }
788 }
789 }
790
791 if ($filename !~ /$self->{'process_exp'}/ || !-f $filename) {
792 return (undef,undef); # can't recognise
793 }
794
795 return (1,$filename);
796}
797
798sub read_tidy_file {
799
800 my $self = shift (@_);
801
802 my ($file) = @_;
803
804 $file =~ s/^[\/\\]+//; # $file often begins with / so we'll tidy it up
805
806 return $file;
807}
808
809
810sub filename_to_metadata
811{
812 my $self = shift (@_);
813 my ($file, $encoding) = @_;
814
815 my $outhandle = $self->{'outhandle'};
816
817 my $filesystem_encoding = undef;
818
819 eval {
820 use POSIX qw(locale_h);
821
822 # With only one parameter, setlocale retrieves the current value
823 my $current_locale = setlocale(LC_CTYPE);
824
825 if ($current_locale =~ m/^.*\.(.*?)$/) {
826 my $char_encoding = lc($1);
827 $char_encoding =~ s/-/_/g;
828 $char_encoding =~ s/^utf_8$/utf8/;
829
830 if ($char_encoding =~ m/^\d+$/) {
831 if (defined $encodings::encoding->{"windows_$char_encoding"}) {
832 $char_encoding = "windows_$char_encoding";
833 }
834 elsif (defined $encodings::encoding->{"dos_$char_encoding"}) {
835 $char_encoding = "dos_$char_encoding";
836 }
837 }
838
839 if (($char_encoding =~ m/(?:ascii|utf8|unicode)/)
840 || (defined $encodings::encoding->{$char_encoding})) {
841 $filesystem_encoding = $char_encoding;
842 }
843 else {
844 print $outhandle "Warning: Unsupported character encoding '$char_encoding' from locale '$current_locale'\n";
845 }
846 }
847
848
849 };
850 if ($@) {
851 print $outhandle "$@\n";
852 print $outhandle "Warning: Unable to establish locale. Will assume filesytem is UTF-8\n";
853
854 }
855
856 my ($filemeta) = $file =~ /([^\\\/]+)$/;
857
858 # how do we know what encoding the filename is in?
859 # => one answer is to check the locale
860
861 if (defined $filesystem_encoding) {
862 if ($filesystem_encoding !~ /(?:ascii|utf8|unicode)/) {
863 $filemeta = unicode::unicode2utf8(
864 unicode::convert2unicode($filesystem_encoding, \$filemeta)
865 );
866 }
867 }
868 # assume it is in the same encoding as its contents
869 elsif ((defined $encoding) && ($encoding !~ /(?:ascii|utf8|unicode)/)) {
870 $filemeta = unicode::unicode2utf8(
871 unicode::convert2unicode($encoding, \$filemeta)
872 );
873 }
874
875 my $dmsafe_filemeta = &ghtml::dmsafe($filemeta);
876
877 return $dmsafe_filemeta;
878}
879
880
881sub add_OID
882{
883 my $self = shift (@_);
884 my ($doc_obj) = @_;
885
886 # See if a metadata field is specified as the field
887 if ((defined $self->{'use_as_doc_identifier'}) && ($self->{'use_as_doc_identifier'} ne "")) {
888 my $metadata_doc_id = $self->{'use_as_doc_identifier'};
889
890 # Consider "tidying" up metadata_doc_id to be something
891 # suitable in a URL
892 # Could even support a user specified plugin RE for this.
893
894 my $top_section = $doc_obj->get_top_section();
895 my $oid = $doc_obj->get_metadata_element($top_section,$metadata_doc_id);
896## print STDERR "**** oid = $oid\n";
897 $doc_obj->set_OID($oid);
898 }
899 # See if there is a plugin-specific set_OID function...
900 elsif (defined ($self->can('set_OID'))) {
901 # it will need $doc_obj to set the Identifier metadata...
902 $self->set_OID(@_); # pass through any extra arguments supplied
903 } else {
904 # use the default set_OID() in doc.pm
905 $doc_obj->set_OID();
906 }
907}
908
909# The BasPlug read_into_doc_obj() function. This function does all the
910# right things to make general options work for a given plugin. It reads in
911# a file and sets up a slew of metadata all saved in doc_obj, which
912# it then returns as part of a tuple (process_status,doc_obj)
913#
914# Much of this functionality used to reside in read, but it was broken
915# down into a supporting routine to make the code more flexible.
916#
917# recursive plugins (e.g. RecPlug) and specialized plugins like those
918# capable of processing many documents within a single file (e.g.
919# GMLPlug) will normally want to implement their own version of
920# read_into_doc_obj()
921#
922# Note that $base_dir might be "" and that $file might
923# include directories
924sub read_into_doc_obj {
925 my $self = shift (@_);
926 my ($pluginfo, $base_dir, $file, $metadata, $processor, $maxdocs, $total_count, $gli) = @_;
927
928 if ($self->is_recursive()) {
929 gsprintf(STDERR, "{BasPlug.read_must_be_implemented}") && die "\n";
930 }
931
932 my $outhandle = $self->{'outhandle'};
933
934 my ($block_status,$filename) = $self->read_block(@_);
935 return $block_status if ((!defined $block_status) || ($block_status==0));
936 $file = $self->read_tidy_file($file);
937
938 # Do encoding stuff
939 my ($language, $encoding) = $self->textcat_get_language_encoding ($filename);
940 if ($self->{'verbosity'} > 2) {
941 print $outhandle "BasPlug: reading $file as ($encoding,$language)\n";
942 }
943
944 # create a new document
945 my $doc_obj = new doc ($filename, "indexed_doc");
946 my $top_section = $doc_obj->get_top_section();
947
948 $doc_obj->set_OIDtype ($processor->{'OIDtype'}, $processor->{'OIDmetadata'});
949 $doc_obj->add_utf8_metadata($top_section, "Language", $language);
950 $doc_obj->add_utf8_metadata($top_section, "Encoding", $encoding);
951 $doc_obj->add_utf8_metadata($top_section, "Plugin", "$self->{'plugin_type'}");
952 $doc_obj->add_utf8_metadata($top_section, "FileSize", (-s $filename));
953
954 my $filemeta = $self->filename_to_metadata($file,$encoding);
955 $doc_obj->add_utf8_metadata($top_section, "Source", $filemeta);
956 if ($self->{'cover_image'}) {
957 $self->associate_cover_image($doc_obj, $filename);
958 }
959
960 # read in file ($text will be in utf8)
961 my $text = "";
962 $self->read_file ($filename, $encoding, $language, \$text);
963
964 if (!length ($text)) {
965 my $plugin_name = ref ($self);
966 if ($gli) {
967 print STDERR "<ProcessingError n='$file' r='File contains no text'>\n";
968 }
969 gsprintf($outhandle, "$plugin_name: {BasPlug.file_has_no_text}\n", $filename) if $self->{'verbosity'};
970
971 my $failhandle = $self->{'failhandle'};
972 gsprintf($failhandle, "$file: " . ref($self) . ": {BasPlug.empty_file}\n");
973 # print $failhandle "$file: " . ref($self) . ": file contains no text\n";
974 $self->{'num_not_processed'} ++;
975
976 return (0,undef); # what should we return here?? error but don't want to pass it on
977 }
978
979 # include any metadata passed in from previous plugins
980 # note that this metadata is associated with the top level section
981
982 my $associate_tail_re = $self->{'associate_tail_re'};
983
984 $self->extra_metadata ($doc_obj, $doc_obj->get_top_section(), $metadata);
985
986 # do plugin specific processing of doc_obj
987 unless (defined ($self->process (\$text, $pluginfo, $base_dir, $file, $metadata, $doc_obj, $gli))) {
988 $text = '';
989 undef $text;
990 print STDERR "<ProcessingError n='$file'>\n" if ($gli);
991 return (-1,undef);
992 }
993 $text='';
994 undef $text;
995
996 # do any automatic metadata extraction
997 $self->auto_extract_metadata ($doc_obj);
998
999 $self->add_OID($doc_obj);
1000
1001 return (1,$doc_obj);
1002}
1003
1004
1005# The BasPlug read() function. This function calls read_into_doc_obj()
1006# to ensure all the right things to make general options work for a
1007# given plugin are done. It then calls the process() function which
1008# does all the work specific to a plugin (like the old read functions
1009# used to do). Most plugins should define their own process() function
1010# and let this read() function keep control.
1011#
1012# recursive plugins (e.g. RecPlug) and specialized plugins like those
1013# capable of processing many documents within a single file (e.g.
1014# GMLPlug) might want to implement their own version of read(), but
1015# more likely need to implement their own version of read_into_doc_obj()
1016#
1017# Return number of files processed, undef if can't recognise, -1 if can't
1018# process
1019
1020sub read {
1021 my $self = shift (@_);
1022 my ($pluginfo, $base_dir, $file, $metadata, $processor, $maxdocs, $total_count, $gli) = @_;
1023
1024 my ($process_status,$doc_obj) = $self->read_into_doc_obj(@_);
1025
1026 if ((defined $process_status) && ($process_status == 1)) {
1027 # process the document
1028 $processor->process($doc_obj);
1029
1030 if(defined($self->{'places_filename'})){
1031 &util::rm($self->{'places_filename'});
1032 $self->{'places_filename'} = undef;
1033 }
1034
1035 $self->{'num_processed'} ++;
1036 undef $doc_obj;
1037 }
1038
1039 # if process_status == 1, then the file has been processed.
1040 return $process_status;
1041
1042}
1043
1044# returns undef if file is rejected by the plugin
1045sub process {
1046 my $self = shift (@_);
1047 my ($textref, $pluginfo, $base_dir, $file, $metadata, $doc_obj, $gli) = @_;
1048
1049 gsprintf(STDERR, "BasPlug::process {common.must_be_implemented}\n") && die "\n";
1050 # die "Basplug::process function must be implemented in sub-class\n";
1051
1052 return undef; # never gets here
1053}
1054
1055# uses the multiread package to read in the entire file pointed to
1056# by filename and loads the resulting text into $$textref. Input text
1057# may be in any of the encodings handled by multiread, output text
1058# will be in utf8
1059sub read_file {
1060 my $self = shift (@_);
1061 my ($filename, $encoding, $language, $textref) = @_;
1062
1063 if (!-r $filename)
1064 {
1065 my $outhandle = $self->{'outhandle'};
1066 gsprintf($outhandle, "{BasPlug.read_denied}\n", $filename) if $self->{'verbosity'};
1067 # print $outhandle "Read permission denied for $filename\n" if $self->{'verbosity'};
1068 return;
1069 }
1070 $$textref = "";
1071 if (!open (FILE, $filename)) {
1072 gsprintf(STDERR, "BasPlug::read_file {BasPlug.could_not_open_for_reading} ($!)\n", $filename);
1073 die "\n";
1074 }
1075
1076 if ($encoding eq "ascii") {
1077 undef $/;
1078 $$textref = <FILE>;
1079 $/ = "\n";
1080 } else {
1081 my $reader = new multiread();
1082 $reader->set_handle ('BasPlug::FILE');
1083 $reader->set_encoding ($encoding);
1084 $reader->read_file ($textref);
1085 #Now segments chinese if the separate_cjk option is set
1086 if ($self->{'separate_cjk'}) {
1087 # segment the Chinese words
1088 $$textref = &cnseg::segment($$textref);
1089 }
1090 }
1091 close FILE;
1092}
1093
1094# write_file -- used by ConvertToPlug, for example in post processing
1095#
1096sub utf8_write_file {
1097 my $self = shift (@_);
1098 my ($textref, $filename) = @_;
1099
1100 if (!open (FILE, ">$filename")) {
1101 gsprintf(STDERR, "ConvertToPlug::write_file {ConvertToPlug.could_not_open_for_writing} ($!)\n", $filename);
1102 die "\n";
1103 }
1104 print FILE $$textref;
1105
1106 close FILE;
1107}
1108
1109
1110sub filename_based_title
1111{
1112 my $self = shift (@_);
1113 my ($file) = @_;
1114
1115 my $file_derived_title = $file;
1116 $file_derived_title =~ s/_/ /g;
1117 $file_derived_title =~ s/\..*?$//;
1118
1119 return $file_derived_title;
1120}
1121
1122
1123sub title_fallback
1124{
1125 my $self = shift (@_);
1126 my ($doc_obj,$section,$file) = @_;
1127
1128 if (!defined $doc_obj->get_metadata_element ($section, "Title")) {
1129
1130 my $file_derived_title = $self->filename_based_title($file);
1131
1132 $doc_obj->add_utf8_metadata ($section, "Title", $self->filename_to_metadata($file_derived_title));
1133 }
1134}
1135
1136sub textcat_get_language_encoding {
1137 my $self = shift (@_);
1138 my ($filename) = @_;
1139
1140
1141 my ($language, $encoding, $extracted_encoding);
1142 if ($self->{'input_encoding'} eq "auto") {
1143 # use textcat to automatically work out the input encoding and language
1144 ($language, $encoding) = $self->get_language_encoding ($filename);
1145 } elsif ($self->{'extract_language'}) {
1146 # use textcat to get language metadata
1147 ($language, $extracted_encoding) = $self->get_language_encoding ($filename);
1148 $encoding = $self->{'input_encoding'};
1149 # don't print this message for english... english in utf8 is identical
1150 # to english in iso-8859-1 (except for some punctuation). We don't have
1151 # a language model for en_utf8, so textcat always says iso-8859-1!
1152 if ($extracted_encoding ne $encoding && $language ne "en"
1153 && $self->{'verbosity'}) {
1154 my $plugin_name = ref ($self);
1155 my $outhandle = $self->{'outhandle'};
1156 gsprintf($outhandle, "$plugin_name: {BasPlug.wrong_encoding}\n", $filename, $encoding, $extracted_encoding);
1157 }
1158 } else {
1159 $language = $self->{'default_language'};
1160 $encoding = $self->{'input_encoding'};
1161 }
1162
1163 return ($language, $encoding);
1164}
1165
1166# Uses textcat to work out the encoding and language of the text in
1167# $filename. All html tags are removed before processing.
1168# returns an array containing "language" and "encoding"
1169sub get_language_encoding {
1170 my $self = shift (@_);
1171 my ($filename) = @_;
1172 my $outhandle = $self->{'outhandle'};
1173 my $unicode_format = "";
1174 my $best_language = "";
1175 my $best_encoding = "";
1176
1177 # read in file
1178 if (!open (FILE, $filename)) {
1179 gsprintf(STDERR, "BasPlug::get_language_encoding {BasPlug.could_not_open_for_reading} ($!)\n", $filename);
1180 # this is a pretty bad error, but try to continue anyway
1181 return ($self->{'default_language'}, $self->{'input_encoding'});
1182 }
1183 undef $/;
1184 my $text = <FILE>;
1185 $/ = "\n";
1186 close FILE;
1187
1188 # check if first few bytes have a Byte Order Marker
1189 my $bom=substr($text,0,2); # check 16bit unicode
1190 if ($bom eq "\xff\xfe") { # little endian 16bit unicode
1191 $unicode_format="unicode";
1192 } elsif ($bom eq "\xfe\xff") { # big endian 16bit unicode
1193 $unicode_format="unicode";
1194 } else {
1195 $bom=substr($text,0,3); # check utf-8
1196 if ($bom eq "\xef\xbb\xbf") { # utf-8 coded FEFF bom
1197 $unicode_format="utf8";
1198# } elsif ($bom eq "\xef\xbf\xbe") { # utf-8 coded FFFE bom. Error!?
1199# $unicode_format="utf8";
1200 }
1201 }
1202
1203
1204 # handle html files specially
1205 # XXX this doesn't match plugins derived from HTMLPlug (except ConvertTo)
1206 if (ref($self) eq 'HTMLPlug' ||
1207 (exists $self->{'converted_to'} && $self->{'converted_to'} eq 'HTML')){
1208
1209 # remove <title>stuff</title> -- as titles tend often to be in English
1210 # for foreign language documents
1211 $text =~ s!<title>.*?</title>!!si;
1212
1213 # see if this html file specifies its encoding
1214 if ($text =~ /^<\?xml.*encoding="(.+?)"/) {
1215 $best_encoding = $1;
1216 } elsif ($text =~ /<meta http-equiv.*content-type.*charset=(.+?)"/i) {#"
1217 $best_encoding = $1;
1218 }
1219 if ($best_encoding) { # we extracted an encoding
1220 $best_encoding =~ s/-+/_/g;
1221 $best_encoding = lc($best_encoding); # lowercase
1222 if ($best_encoding eq "utf_8") { $best_encoding = "utf8" }
1223 $self->{'input_encoding'} = $best_encoding;
1224 }
1225
1226 # remove all HTML tags
1227 $text =~ s/<[^>]*>//sg;
1228 }
1229
1230 # get the language/encoding
1231 $self->{'textcat'} = new textcat() if (!defined($self->{'textcat'}));
1232 my $results = $self->{'textcat'}->classify(\$text);
1233
1234 # if textcat returns 3 or less possibilities we'll use the
1235 # first one in the list - otherwise use the defaults
1236 if (scalar @$results > 3) {
1237 if ($unicode_format) { # in case the first had a BOM
1238 $best_encoding=$unicode_format;
1239 } else {
1240 my %guessed_encodings = ();
1241 foreach my $result (@$results) {
1242 $result =~ /([^\-]+)$/;
1243 my $enc=$1;
1244 if (!defined($guessed_encodings{$enc})) {
1245 $guessed_encodings{$enc}=0;
1246 }
1247 $guessed_encodings{$enc}++;
1248 }
1249
1250 $guessed_encodings{""}=-1; # for default best_encoding of ""
1251 foreach my $enc (keys %guessed_encodings) {
1252 if ($guessed_encodings{$enc} >
1253 $guessed_encodings{$best_encoding}){
1254 $best_encoding=$enc;
1255 }
1256 }
1257 }
1258
1259 if ($self->{'input_encoding'} ne 'auto') {
1260 if ($self->{'extract_language'} && ($self->{'verbosity'}>2)) {
1261 gsprintf($outhandle,
1262 "BasPlug: {BasPlug.could_not_extract_language}\n",
1263 $filename, $self->{'default_language'});
1264 }
1265 $best_language = $self->{'default_language'};
1266 $best_encoding = $self->{'input_encoding'};
1267
1268 } else {
1269 if ($self->{'verbosity'}>2) {
1270 gsprintf($outhandle,
1271 "BasPlug: {BasPlug.could_not_extract_language}\n",
1272 $filename, $self->{'default_language'});
1273 }
1274 $best_language = $self->{'default_language'};
1275 }
1276 } else { # <= 3 suggestions
1277 my ($language, $encoding) = $results->[0] =~ /^([^-]*)(?:-(.*))?$/;
1278 if (!defined $language) {
1279 if ($self->{'verbosity'}>2) {
1280 gsprintf($outhandle,
1281 "BasPlug: {BasPlug.could_not_extract_language}\n",
1282 $filename, $self->{'default_language'});
1283 }
1284 $language = $self->{'default_language'};
1285 }
1286 if (!defined $encoding) {
1287 if ($self->{'verbosity'}>2) {
1288 gsprintf($outhandle,
1289 "BasPlug: {BasPlug.could_not_extract_encoding}\n",
1290 $filename, $self->{'default_encoding'});
1291 }
1292 $encoding = $self->{'default_encoding'};
1293 }
1294 $best_language = $language;
1295 if (! $best_encoding ) { # may already be set... eg from html meta tag
1296 $best_encoding = $encoding;
1297 }
1298 }
1299
1300 my $text_copy = $text;
1301 if ($best_encoding =~ /^iso_8859/ && unicode::ensure_utf8(\$text_copy)==0) {
1302 # the text is valid utf8, so assume that's the real encoding
1303 # (since textcat is based on probabilities)
1304 $best_encoding = 'utf8';
1305 }
1306
1307 # check for equivalents where textcat doesn't have some encodings...
1308 # eg MS versions of standard encodings
1309 if ($best_encoding =~ /^iso_8859_(\d+)/) {
1310 my $iso = $1; # which variant of the iso standard?
1311 # iso-8859 sets don't use chars 0x80-0x9f, windows codepages do
1312 if ($text =~ /[\x80-\x9f]/) {
1313 # Western Europe
1314 if ($iso == 1 or $iso == 15) { $best_encoding = 'windows_1252' }
1315 elsif ($iso == 2) {$best_encoding = 'windows_1250'} # Central Europe
1316 elsif ($iso == 5) {$best_encoding = 'windows_1251'} # Cyrillic
1317 elsif ($iso == 6) {$best_encoding = 'windows_1256'} # Arabic
1318 elsif ($iso == 7) {$best_encoding = 'windows_1253'} # Greek
1319 elsif ($iso == 8) {$best_encoding = 'windows_1255'} # Hebrew
1320 elsif ($iso == 9) {$best_encoding = 'windows_1254'} # Turkish
1321 }
1322 }
1323
1324 if ($best_encoding !~ /^(ascii|utf8|unicode)$/ &&
1325 !defined $encodings::encodings->{$best_encoding}) {
1326 if ($self->{'verbosity'}) {
1327 gsprintf($outhandle, "BasPlug: {BasPlug.unsupported_encoding}\n",
1328 $filename, $best_encoding, $self->{'default_encoding'});
1329 }
1330 $best_encoding = $self->{'default_encoding'};
1331 }
1332
1333 return ($best_language, $best_encoding);
1334}
1335
1336# add any extra metadata that's been passed around from one
1337# plugin to another.
1338# extra_metadata uses add_utf8_metadata so it expects metadata values
1339# to already be in utf8
1340sub extra_metadata {
1341 my $self = shift (@_);
1342 my ($doc_obj, $cursection, $metadata) = @_;
1343
1344 my $associate_tail_re = $self->{'associate_tail_re'};
1345
1346 foreach my $field (keys(%$metadata)) {
1347 # $metadata->{$field} may be an array reference
1348 if ($field eq "gsdlassocfile_tobe") {
1349 # 'gsdlassocfile_tobe' is artificially introduced metadata
1350 # that is used to signal that certain additional files should
1351 # be tied to this document. Useful in situations where a
1352 # metadata pass in the plugin pipeline works out some files
1353 # need to be associated with a document, but the document hasn't
1354 # been formed yet.
1355
1356 my $equiv_form = "";
1357 foreach my $gaf (@{$metadata->{$field}}) {
1358 my ($full_filename,$mimetype) = ($gaf =~ m/^(.*):(.*):$/);
1359 my ($tail_filename) = ($full_filename =~ /^.*[\/\\](.+?)$/);
1360 my $filename = $full_filename;
1361
1362 $doc_obj->associate_file($full_filename,$tail_filename,$mimetype);
1363
1364 # work out extended tail extension (i.e. matching tail re)
1365
1366 my ($file_prefix,$file_extended_ext)
1367 = $self->root_ext_split($tail_filename,$associate_tail_re);
1368 my ($pre_doc_ext) = ($file_extended_ext =~ m/^(.*)\..*$/);
1369
1370 my ($doc_ext) = ($tail_filename =~ m/^.*\.(.*)$/);
1371 my $start_doclink = "<a href=\"_httpprefix_/collect/[collection]/index/assoc/{Or}{[parent(Top):archivedir],[archivedir]}/$tail_filename\">";
1372 my $srcicon = "_icon".$doc_ext."_";
1373 my $end_doclink = "</a>";
1374
1375 my $assoc_form = "$start_doclink\{If\}{$srcicon,$srcicon,$doc_ext\}$end_doclink";
1376
1377 if (defined $pre_doc_ext) {
1378 # for metadata such as [mp3._edited] [mp3._full] ...
1379 $doc_obj->add_utf8_metadata ($cursection, "$doc_ext.$pre_doc_ext", $assoc_form);
1380 }
1381
1382 # for multiple metadata such as [mp3.assoclink]
1383 $doc_obj->add_utf8_metadata ($cursection, "$doc_ext.assoclink", $assoc_form);
1384
1385 $equiv_form .= " $assoc_form";
1386 }
1387 $doc_obj->add_utf8_metadata ($cursection, "equivlink", $equiv_form);
1388 }
1389 elsif (ref ($metadata->{$field}) eq "ARRAY") {
1390 map {
1391 $doc_obj->add_utf8_metadata ($cursection, $field, $_);
1392 } @{$metadata->{$field}};
1393 } else {
1394 $doc_obj->add_utf8_metadata ($cursection, $field, $metadata->{$field});
1395 }
1396 }
1397}
1398
1399# initialise metadata extractors
1400sub initialise_extractors {
1401 my $self = shift (@_);
1402
1403 if ($self->{'extract_acronyms'} || $self->{'markup_acronyms'}) {
1404 &acronym::initialise_acronyms();
1405 }
1406}
1407
1408# finalise metadata extractors
1409sub finalise_extractors {
1410 my $self = shift (@_);
1411
1412 if ($self->{'extract_acronyms'} || $self->{'markup_acronyms'}) {
1413 &acronym::finalise_acronyms();
1414 }
1415}
1416
1417# FIRSTNNN: extract the first NNN characters as metadata
1418sub extract_first_NNNN_characters {
1419 my $self = shift (@_);
1420 my ($textref, $doc_obj, $thissection) = @_;
1421
1422 foreach my $size (split /,/, $self->{'first'}) {
1423 my $tmptext = $$textref;
1424 $tmptext =~ s/^\s+//;
1425 $tmptext =~ s/\s+$//;
1426 $tmptext =~ s/\s+/ /gs;
1427 $tmptext = substr ($tmptext, 0, $size);
1428 $tmptext =~ s/\s\S*$/&#8230;/;
1429 $doc_obj->add_utf8_metadata ($thissection, "First$size", $tmptext);
1430 }
1431}
1432
1433sub extract_email {
1434 my $self = shift (@_);
1435 my ($textref, $doc_obj, $thissection) = @_;
1436 my $outhandle = $self->{'outhandle'};
1437
1438 gsprintf($outhandle, " {BasPlug.extracting_emails}...\n")
1439 if ($self->{'verbosity'} > 2);
1440
1441 my @email = ($$textref =~ m/([-a-z0-9\.@+_=]+@(?:[-a-z0-9]+\.)+(?:com|org|edu|mil|int|net|[a-z][a-z]))/g);
1442 @email = sort @email;
1443
1444# if($self->{"new_extract_email"} == 0)
1445# {
1446# my @email2 = ();
1447# foreach my $address (@email)
1448# {
1449# if (!(join(" ",@email2) =~ m/(^| )$address( |$)/ ))
1450# {
1451# push @email2, $address;
1452# $doc_obj->add_utf8_metadata ($thissection, "emailAddress", $address);
1453# # print $outhandle " extracting $address\n"
1454# &gsprintf($outhandle, " {BasPlug.extracting} $address\n")
1455# if ($self->{'verbosity'} > 3);
1456# }
1457# }
1458# }
1459# else
1460# {
1461 my $hashExistMail = {};
1462 foreach my $address (@email) {
1463 if (!(defined $hashExistMail->{$address}))
1464 {
1465 $hashExistMail->{$address} = 1;
1466 $doc_obj->add_utf8_metadata ($thissection, "emailAddress", $address);
1467 gsprintf($outhandle, " {BasPlug.extracting} $address\n")
1468 if ($self->{'verbosity'} > 3);
1469 }
1470 }
1471 gsprintf($outhandle, " {BasPlug.done_email_extract}\n")
1472 if ($self->{'verbosity'} > 2);
1473}
1474
1475# extract metadata
1476sub auto_extract_metadata {
1477
1478 my $self = shift (@_);
1479 my ($doc_obj) = @_;
1480
1481 if ($self->{'extract_email'}) {
1482 my $thissection = $doc_obj->get_top_section();
1483 while (defined $thissection) {
1484 my $text = $doc_obj->get_text($thissection);
1485 $self->extract_email (\$text, $doc_obj, $thissection) if $text =~ /./;
1486 $thissection = $doc_obj->get_next_section ($thissection);
1487 }
1488 }
1489 if ($self->{'extract_placenames'}) {
1490 my $thissection = $doc_obj->get_top_section();
1491 while (defined $thissection) {
1492 my $text = $doc_obj->get_text($thissection);
1493 $self->extract_placenames (\$text, $doc_obj, $thissection) if $text =~ /./;
1494 $thissection = $doc_obj->get_next_section ($thissection);
1495 }
1496 }
1497
1498 if ($self->{'extract_keyphrases'} || $self->{'extract_keyphrases_kea4'}) {
1499 $self->extract_keyphrases($doc_obj);
1500 }
1501
1502 if ($self->{'first'}) {
1503 my $thissection = $doc_obj->get_top_section();
1504 while (defined $thissection) {
1505 my $text = $doc_obj->get_text($thissection);
1506 $self->extract_first_NNNN_characters (\$text, $doc_obj, $thissection) if $text =~ /./;
1507 $thissection = $doc_obj->get_next_section ($thissection);
1508 }
1509 }
1510
1511 if ($self->{'extract_acronyms'}) {
1512 my $thissection = $doc_obj->get_top_section();
1513 while (defined $thissection) {
1514 my $text = $doc_obj->get_text($thissection);
1515 $self->extract_acronyms (\$text, $doc_obj, $thissection) if $text =~ /./;
1516 $thissection = $doc_obj->get_next_section ($thissection);
1517 }
1518 }
1519
1520 if ($self->{'markup_acronyms'}) {
1521 my $thissection = $doc_obj->get_top_section();
1522 while (defined $thissection) {
1523 my $text = $doc_obj->get_text($thissection);
1524 $text = $self->markup_acronyms ($text, $doc_obj, $thissection);
1525 $doc_obj->delete_text($thissection);
1526 $doc_obj->add_text($thissection, $text);
1527 $thissection = $doc_obj->get_next_section ($thissection);
1528 }
1529 }
1530
1531 if($self->{'extract_historical_years'}) {
1532 my $thissection = $doc_obj->get_top_section();
1533 while (defined $thissection) {
1534
1535 my $text = $doc_obj->get_text($thissection);
1536 &DateExtract::get_date_metadata($text, $doc_obj,
1537 $thissection,
1538 $self->{'no_bibliography'},
1539 $self->{'maximum_year'},
1540 $self->{'maximum_century'});
1541 $thissection = $doc_obj->get_next_section ($thissection);
1542 }
1543 }
1544}
1545
1546
1547#adding kea keyphrases
1548sub extract_keyphrases
1549{
1550 my $self = shift(@_);
1551 my $doc_obj = shift(@_);
1552
1553 # Use Kea 3.0 unless 4.0 has been specified
1554 my $kea_version = "3.0";
1555 if ($self->{'extract_keyphrases_kea4'}) {
1556 $kea_version = "4.0";
1557 }
1558
1559 # Check that Kea exists, and tell the user where to get it if not
1560 my $keahome = &Kea::get_Kea_directory($kea_version);
1561 if (!-e $keahome) {
1562 gsprintf(STDERR, "{BasPlug.missing_kea}\n", $keahome, $kea_version);
1563 return;
1564 }
1565
1566 my $thissection = $doc_obj->get_top_section();
1567 my $text = "";
1568 my $list;
1569
1570 #loop through sections to gather whole doc
1571 while (defined $thissection) {
1572 my $sectiontext = $doc_obj->get_text($thissection);
1573 $text = $text.$sectiontext;
1574 $thissection = $doc_obj->get_next_section ($thissection);
1575 }
1576
1577 if($self->{'extract_keyphrase_options'}) { #if kea options flag is set, call Kea with specified options
1578 $list = &Kea::extract_KeyPhrases ($kea_version, $text, $self->{'extract_keyphrase_options'});
1579 } else { #otherwise call Kea with no options
1580 $list = &Kea::extract_KeyPhrases ($kea_version, $text);
1581 }
1582
1583 if ($list){
1584 # if a list of kea keyphrases was returned (ie not empty)
1585 if ($self->{'verbosity'}) {
1586 gsprintf(STDERR, "{BasPlug.keyphrases}: $list\n");
1587 }
1588
1589 #add metadata to top section
1590 $thissection = $doc_obj->get_top_section();
1591
1592 # add all key phrases as one metadata
1593 $doc_obj->add_metadata($thissection, "Keyphrases", $list);
1594
1595 # add individual key phrases as multiple metadata
1596 foreach my $keyphrase (split(',', $list)) {
1597 $keyphrase =~ s/^\s+|\s+$//g;
1598 $doc_obj->add_metadata($thissection, "Keyphrase", $keyphrase);
1599 }
1600 }
1601}
1602
1603
1604# extract acronyms from a section in a document. progress is
1605# reported to outhandle based on the verbosity. both the Acronym
1606# and the AcronymKWIC metadata items are created.
1607
1608sub extract_acronyms {
1609 my $self = shift (@_);
1610 my ($textref, $doc_obj, $thissection) = @_;
1611 my $outhandle = $self->{'outhandle'};
1612
1613 # print $outhandle " extracting acronyms ...\n"
1614 gsprintf($outhandle, " {BasPlug.extracting_acronyms}...\n")
1615 if ($self->{'verbosity'} > 2);
1616
1617 my $acro_array = &acronym::acronyms($textref);
1618
1619 foreach my $acro (@$acro_array) {
1620
1621 #check that this is the first time ...
1622 my $seen_before = "false";
1623 my $previous_data = $doc_obj->get_metadata($thissection, "Acronym");
1624 foreach my $thisAcro (@$previous_data) {
1625 if ($thisAcro eq $acro->to_string()) {
1626 $seen_before = "true";
1627 if ($self->{'verbosity'} >= 4) {
1628 gsprintf($outhandle, " {BasPlug.already_seen} " .
1629 $acro->to_string() . "\n");
1630 }
1631 }
1632 }
1633
1634 if ($seen_before eq "false") {
1635 #write it to the file ...
1636 $acro->write_to_file();
1637
1638 #do the normal acronym
1639 $doc_obj->add_utf8_metadata($thissection, "Acronym", $acro->to_string());
1640 gsprintf($outhandle, " {BasPlug.adding} ".$acro->to_string()."\n")
1641 if ($self->{'verbosity'} > 3);
1642 }
1643 }
1644
1645 gsprintf($outhandle, " {BasPlug.done_acronym_extract}\n")
1646 if ($self->{'verbosity'} > 2);
1647}
1648
1649sub markup_acronyms {
1650 my $self = shift (@_);
1651 my ($text, $doc_obj, $thissection) = @_;
1652 my $outhandle = $self->{'outhandle'};
1653
1654 gsprintf($outhandle, " {BasPlug.marking_up_acronyms}...\n")
1655 if ($self->{'verbosity'} > 2);
1656
1657 #self is passed in to check for verbosity ...
1658 $text = &acronym::markup_acronyms($text, $self);
1659
1660 gsprintf($outhandle, " {BasPlug.done_acronym_markup}\n")
1661 if ($self->{'verbosity'} > 2);
1662
1663 return $text;
1664}
1665
1666sub compile_stats {
1667 my $self = shift(@_);
1668 my ($stats) = @_;
1669
1670 $stats->{'num_processed'} += $self->{'num_processed'};
1671 $stats->{'num_not_processed'} += $self->{'num_not_processed'};
1672 $stats->{'num_archives'} += $self->{'num_archives'};
1673
1674}
1675
1676sub associate_cover_image {
1677 my $self = shift;
1678 my ($doc_obj, $filename) = @_;
1679
1680 $filename =~ s/\.[^\\\/\.]+$/\.jpg/;
1681 if (exists $self->{'covers_missing_cache'}->{$filename}) {
1682 # don't stat() for existence eg for multiple document input files
1683 # (eg SplitPlug)
1684 return;
1685 }
1686
1687 my $top_section=$doc_obj->get_top_section();
1688
1689 if (-e $filename) {
1690 $doc_obj->associate_file($filename, "cover.jpg", "image/jpeg");
1691 $doc_obj->add_utf8_metadata($top_section, "hascover", 1);
1692 } else {
1693 my $upper_filename = $filename;
1694 $upper_filename =~ s/jpg$/JPG/;
1695 if (-e $upper_filename) {
1696 $doc_obj->associate_file($upper_filename, "cover.jpg",
1697 "image/jpeg");
1698 $doc_obj->add_utf8_metadata($top_section, "hascover", 1);
1699 } else {
1700 # file doesn't exist, so record the fact that it's missing so
1701 # we don't stat() again (stat is slow)
1702 $self->{'covers_missing_cache'}->{$filename} = 1;
1703 }
1704 }
1705
1706}
1707
1708
1709# Overridden by exploding plugins (eg. ISISPlug)
1710sub clean_up_after_exploding
1711{
1712 my $self = shift(@_);
1713}
1714
1715
17161;
Note: See TracBrowser for help on using the repository browser.