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

Last change on this file since 15006 was 15006, checked in by davidb, 14 years ago

More careful handling of the file encoding used in a filename read in from the filesystem

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