root/main/trunk/greenstone2/perllib/plugins/HTMLPlugin.pm @ 23371

Revision 23371, 59.2 KB (checked in by davidb, 9 years ago)

Further refinement of code to support HTML linking between documents when using non-ascii names on Windows

  • Property svn:executable set to *
  • Property svn:keywords set to Author Date Id Revision
Line 
1###########################################################################
2#
3# HTMLPlugin.pm -- basic html plugin
4#
5# A component of the Greenstone digital library software
6# from the New Zealand Digital Library Project at the
7# University of Waikato, New Zealand.
8#
9# Copyright (C) 1999 New Zealand Digital Library Project
10#
11# This program is free software; you can redistribute it and/or modify
12# it under the terms of the GNU General Public License as published by
13# the Free Software Foundation; either version 2 of the License, or
14# (at your option) any later version.
15#
16# This program is distributed in the hope that it will be useful,
17# but WITHOUT ANY WARRANTY; without even the implied warranty of
18# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
19# GNU General Public License for more details.
20#
21# You should have received a copy of the GNU General Public License
22# along with this program; if not, write to the Free Software
23# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
24#
25###########################################################################
26
27#
28# Note that this plugin handles frames only in a very simple way
29# i.e. each frame is treated as a separate document. This means
30# search results will contain links to individual frames rather
31# than linking to the top level frameset.
32# There may also be some problems caused by the _parent target
33# (it's removed by this plugin)
34#
35
36package HTMLPlugin;
37
38use Encode;
39
40use ReadTextFile;
41use HBPlugin;
42use ghtml;
43use unicode;
44use util;
45use XMLParser;
46
47use Image::Size;
48use File::Copy;
49
50sub BEGIN {
51    @HTMLPlugin::ISA = ('ReadTextFile', 'HBPlugin');
52}
53
54use strict; # every perl program should have this!
55no strict 'refs'; # make an exception so we can use variables as filehandles
56
57my $arguments =
58    [ { 'name' => "process_exp",
59    'desc' => "{BasePlugin.process_exp}",
60    'type' => "regexp",
61    'deft' =>  &get_default_process_exp() },
62      { 'name' => "block_exp",
63    'desc' => "{BasePlugin.block_exp}",
64    'type' => 'regexp',
65    'deft' =>  &get_default_block_exp() },
66      { 'name' => "nolinks",
67    'desc' => "{HTMLPlugin.nolinks}",
68    'type' => "flag" },
69      { 'name' => "keep_head",
70    'desc' => "{HTMLPlugin.keep_head}",
71    'type' => "flag" },
72      { 'name' => "no_metadata",
73    'desc' => "{HTMLPlugin.no_metadata}",
74    'type' => "flag" },
75      { 'name' => "metadata_fields",
76    'desc' => "{HTMLPlugin.metadata_fields}",
77    'type' => "string",
78    'deft' => "Title" },
79      { 'name' => "metadata_field_separator",
80    'desc' => "{HTMLPlugin.metadata_field_separator}",
81    'type' => "string",
82    'deft' => "" },
83      { 'name' => "hunt_creator_metadata",
84    'desc' => "{HTMLPlugin.hunt_creator_metadata}",
85    'type' => "flag" },
86      { 'name' => "file_is_url",
87    'desc' => "{HTMLPlugin.file_is_url}",
88    'type' => "flag" },
89      { 'name' => "assoc_files",
90    'desc' => "{HTMLPlugin.assoc_files}",
91    'type' => "regexp",
92    'deft' => &get_default_block_exp() },
93      { 'name' => "rename_assoc_files",
94    'desc' => "{HTMLPlugin.rename_assoc_files}",
95    'type' => "flag" },
96      { 'name' => "title_sub",
97    'desc' => "{HTMLPlugin.title_sub}",
98    'type' => "string",
99    'deft' => "" },
100      { 'name' => "description_tags",
101    'desc' => "{HTMLPlugin.description_tags}",
102    'type' => "flag" },
103      # retain this for backward compatibility (w3mir option was replaced by
104      # file_is_url)
105      { 'name' => "w3mir",
106#   'desc' => "{HTMLPlugin.w3mir}",
107    'type' => "flag",
108    'hiddengli' => "yes"},
109      { 'name' => "no_strip_metadata_html",
110    'desc' => "{HTMLPlugin.no_strip_metadata_html}",
111    'type' => "string",
112    'deft' => "",
113    'reqd' => "no"},
114      { 'name' => "sectionalise_using_h_tags",
115    'desc' => "{HTMLPlugin.sectionalise_using_h_tags}",
116    'type' => "flag" },
117      { 'name' => "use_realistic_book",
118        'desc' => "{HTMLPlugin.tidy_html}",
119    'type' => "flag"},
120      { 'name' => "old_style_HDL",
121        'desc' => "{HTMLPlugin.old_style_HDL}",
122    'type' => "flag"},
123      {'name' => "processing_tmp_files",
124       'desc' => "{BasePlugin.processing_tmp_files}",
125       'type' => "flag",
126       'hiddengli' => "yes"}
127      ];
128
129my $options = { 'name'     => "HTMLPlugin",
130        'desc'     => "{HTMLPlugin.desc}",
131        'abstract' => "no",
132        'inherits' => "yes",
133        'args'     => $arguments };
134
135
136sub new {
137    my ($class) = shift (@_);
138    my ($pluginlist,$inputargs,$hashArgOptLists) = @_;
139    push(@$pluginlist, $class);
140   
141    push(@{$hashArgOptLists->{"ArgList"}},@{$arguments});
142    push(@{$hashArgOptLists->{"OptList"}},$options);
143   
144
145    my $self = new ReadTextFile($pluginlist,$inputargs,$hashArgOptLists);
146   
147    if ($self->{'w3mir'}) {
148    $self->{'file_is_url'} = 1;
149    }
150    $self->{'aux_files'} = {};
151    $self->{'dir_num'} = 0;
152    $self->{'file_num'} = 0;
153   
154    return bless $self, $class;
155}
156
157# may want to use (?i)\.(gif|jpe?g|jpe|png|css|js(?:@.*)?)$
158# if have eg <script language="javascript" src="img/lib.js@123">
159# blocking is now done by reading through the file and recording all the
160# images and other files
161sub get_default_block_exp {
162    my $self = shift (@_);
163   
164    #return q^(?i)\.(gif|jpe?g|jpe|jpg|png|css)$^;
165    return "";
166}
167
168sub get_default_process_exp {
169    my $self = shift (@_);
170   
171    # the last option is an attempt to encode the concept of an html query ...
172    return q^(?i)(\.html?|\.shtml|\.shm|\.asp|\.php\d?|\.cgi|.+\?.+=.*)$^;
173}
174
175sub store_block_files
176{
177    my $self =shift (@_);
178    my ($filename_full_path, $block_hash) = @_;
179
180    my $html_fname = $filename_full_path;
181    my @file_blocks;
182   
183    my ($language, $content_encoding) = $self->textcat_get_language_encoding ($filename_full_path);
184    $self->{'store_content_encoding'}->{$filename_full_path} = $content_encoding;
185
186    # read in file ($text will be in utf8)
187    my $raw_text = "";
188    $self->read_file_no_decoding($filename_full_path, \$raw_text);
189
190    my $textref = \$raw_text;
191    my $opencom = '(?:<!--|&lt;!(?:&mdash;|&#151;|--))';
192    my $closecom = '(?:-->|(?:&mdash;|&#151;|--)&gt;)';
193    $$textref =~ s/$opencom(.*?)$closecom//gs;
194
195    # Convert entities to their UTF8 equivalents
196    $$textref =~ s/&(lt|gt|amp|quot|nbsp);/&z$1;/go;
197    $$textref =~ s/&([^;]+);/&ghtml::getcharequiv($1,1,0)/gseo; # on this occassion, want it left as utf8
198    $$textref =~ s/&z(lt|gt|amp|quot|nbsp);/&$1;/go;
199
200    my $attval = "\\\"[^\\\"]+\\\"|[^\\s>]+";
201    my @img_matches = ($$textref =~ m/<img[^>]*?src\s*=\s*($attval)[^>]*>/igs);
202    my @usemap_matches = ($$textref =~ m/<img[^>]*?usemap\s*=\s*($attval)[^>]*>/igs);
203    my @link_matches = ($$textref =~ m/<link[^>]*?href\s*=\s*($attval)[^>]*>/igs);
204    my @embed_matches = ($$textref =~ m/<embed[^>]*?src\s*=\s*($attval)[^>]*>/igs);
205    my @tabbg_matches = ($$textref =~ m/<(?:body|table|tr|td)[^>]*?background\s*=\s*($attval)[^>]*>/igs);
206    my @script_matches = ($$textref =~ m/<script[^>]*?src\s*=\s*($attval)[^>]*>/igs);
207
208    if(!defined $self->{'utf8_to_original_filename'}) {
209    # maps from utf8 converted link name -> original filename referrred to by (possibly URL-encoded) src url
210    $self->{'utf8_to_original_filename'} = {};
211    }
212
213    foreach my $link (@img_matches, @usemap_matches, @link_matches, @embed_matches, @tabbg_matches, @script_matches) {
214
215    # remove quotes from link at start and end if necessary
216    if ($link =~ m/^\"/) {
217        $link =~ s/^\"//;
218        $link =~ s/\"$//;
219    }
220
221    # remove any anchor names, e.g. foo.html#name becomes foo.html
222    # but watch out for any #'s that are part of entities, such as &#x3B1;
223    $link =~ s/([^&])\#.*$/$1/s;
224
225    # some links may just be anchor names
226    next unless ($link =~ /\S+/);
227
228    if ($link !~ m@^/@ && $link !~ m/^([A-Z]:?)\\/) {
229        # Turn relative file path into full path
230        my $dirname = &File::Basename::dirname($filename_full_path);
231        $link = &util::filename_cat($dirname, $link);
232    }
233    $link = $self->eval_dir_dots($link);
234
235    # this is the actual filename on the filesystem (that the link refers to)
236    my $url_original_filename = $self->opt_url_decode($link);
237
238    # Convert the url_original_filename into its utf8 version. Store the utf8 link along with the url_original_filename
239    my $utf8_link = "";
240    $self->decode_text($link,$content_encoding,$language,\$utf8_link);
241
242    $self->{'utf8_to_original_filename'}->{$utf8_link} = $url_original_filename;
243#   print STDERR "**** utf8_encoded_link to original src filename:\n\t$utf8_link\n\t".$self->{'utf8_to_original_filename'}->{$utf8_link}."\n";
244
245    if ($url_original_filename ne $utf8_link) {
246        my $outhandle = $self->{'outhandle'};
247
248        print $outhandle "URL Encoding $url_original_filename\n";
249        print $outhandle " ->$utf8_link\n";
250    }
251
252   
253    my $unicode_url_original_filename = decode("utf8",$url_original_filename);
254
255##  print STDERR "*****!!! Blocking url original filename = $unicode_url_original_filename\n";
256
257    # Allow for possibility of raw byte version (UTF8) and Unicode versions of file
258    $block_hash->{'file_blocks'}->{$url_original_filename} = 1;
259    $block_hash->{'file_blocks'}->{$unicode_url_original_filename} = 1;
260    }
261}
262
263# Given a filename in any encoding, will URL decode it to get back the original filename
264# in the original encoding. Because this method is intended to work out the *original*
265# filename*, it does not URL decode any filename if a file by the name of the *URL-encoded*
266# string already exists in the local folder.
267#
268# Is the following still true??
269# Return the original filename corresponding to the parameter URL-encoded filename, and
270# a decoded flag that is set to true iff URL-decoding had to be applied.
271sub opt_url_decode {
272    my $self = shift (@_);
273    my ($link) = @_;
274
275    # Replace %XX's in URL with decoded value if required.
276    # Note that the filename may include the %XX in some situations
277    if ($link =~ m/\%[A-F0-9]{2}/i) {
278    if (!-e $link) {
279        $link = &unicode::url_decode($link);
280    }
281    }
282
283    return $link;
284}
285
286sub read_into_doc_obj
287{
288    my $self = shift (@_); 
289    my ($pluginfo, $base_dir, $file, $block_hash, $metadata, $processor, $maxdocs, $total_count, $gli) = @_;
290       
291    my ($filename_full_path, $filename_no_path) = &util::get_full_filenames($base_dir, $file);
292
293    # Lookup content_encoding worked out in file_block pass for this file
294    # Store it under the local name 'content_encoding' so its nice and
295    # easy to access
296    $self->{'content_encoding'} = $self->{'store_content_encoding'}->{$filename_full_path};
297
298    # get the input file
299    my $input_filename = $file;
300    my ($tailname, $dirname, $suffix) = &File::Basename::fileparse($input_filename, "\\.[^\\.]+\$");
301    $suffix = lc($suffix);   
302    my $tidy_filename;
303    if (($self->{'use_realistic_book'}) || ($self->{'old_style_HDL'}))
304    {
305    # because the document has to be sectionalized set the description tags
306    $self->{'description_tags'} = 1;
307   
308    # set the file to be tidied
309    $input_filename = &util::filename_cat($base_dir,$file) if $base_dir =~ m/\w/;
310   
311    # get the tidied file
312    #my $tidy_filename = $self->tmp_tidy_file($input_filename);
313    $tidy_filename = $self->convert_tidy_or_oldHDL_file($input_filename);
314   
315    # derive tmp filename from input filename
316    my ($tailname, $dirname, $suffix) = &File::Basename::fileparse($tidy_filename, "\\.[^\\.]+\$");
317   
318    # set the new input file and base_dir to be from the tidied file
319    $file = "$tailname$suffix";
320    $base_dir = $dirname;
321    }
322   
323    # call the parent read_into_doc_obj
324    my ($process_status,$doc_obj) = $self->SUPER::read_into_doc_obj($pluginfo, $base_dir, $file, $block_hash, $metadata, $processor, $maxdocs, $total_count, $gli);
325    if (($self->{'use_realistic_book'}) || ($self->{'old_style_HDL'}))
326    {
327    # now we need to reset the filenames in the doc obj so that the converted filenames are not used
328    my $collect_file = &util::filename_within_collection($filename_full_path);
329    $doc_obj->set_source_filename ($collect_file, $self->{'file_rename_method'});
330    ## set_source_filename does not set the doc_obj source_path which is used in archives dbs for incremental
331    # build. So set it manually.
332    $doc_obj->set_source_path($filename_full_path);
333    my $collect_conv_file = &util::filename_within_collection($tidy_filename);
334    $doc_obj->set_converted_filename($collect_conv_file);
335
336    my $plugin_filename_encoding = $self->{'filename_encoding'};
337    my $filename_encoding = $self->deduce_filename_encoding($file,$metadata,$plugin_filename_encoding);
338    $self->set_Source_metadata($doc_obj, $filename_full_path, $filename_encoding);
339    }
340
341    delete $self->{'store_content_encoding'}->{$filename_full_path};
342    $self->{'content_encoding'} = undef;
343
344    return ($process_status,$doc_obj);
345}
346
347# do plugin specific processing of doc_obj
348sub process {
349    my $self = shift (@_);
350    my ($textref, $pluginfo, $base_dir, $file, $metadata, $doc_obj, $gli) = @_;
351    my $outhandle = $self->{'outhandle'};
352
353    if ($ENV{'GSDLOS'} =~ m/^windows/i) {
354    # this makes life so much easier... perl can cope with unix-style '/'s.
355    $base_dir =~ s@(\\)+@/@g;
356    $file =~ s@(\\)+@/@g;     
357    }
358
359    my $filename = &util::filename_cat($base_dir,$file);
360    my $upgraded_base_dir = &util::upgrade_if_dos_filename($base_dir);
361    my $upgraded_filename = &util::upgrade_if_dos_filename($filename);
362
363    if ($ENV{'GSDLOS'} =~ m/^windows/i) {
364    # And again
365    $upgraded_base_dir =~ s@(\\)+@/@g; 
366    $upgraded_filename =~ s@(\\)+@/@g;
367   
368    # Need to make sure there is a '/' on the end of upgraded_base_dir
369    if ($upgraded_base_dir !~ m/\/$/) {
370        $upgraded_base_dir .= "/";
371    }
372    }
373    my $upgraded_file = &util::filename_within_directory($upgraded_filename,$upgraded_base_dir);
374   
375    # reset per-doc stuff...
376    $self->{'aux_files'} = {};
377    $self->{'dir_num'} = 0;
378    $self->{'file_num'} = 0;
379
380    # process an HTML file where sections are divided by headings tags (H1, H2 ...)
381    # you can also include metadata in the format (X can be any number)
382    # <hX>Title<!--gsdl-metadata
383    #   <Metadata name="name1">value1</Metadata>
384    #   ...
385    #   <Metadata name="nameN">valueN</Metadata>
386    #--></hX>
387    if ($self->{'sectionalise_using_h_tags'}) {
388    # description_tags should allways be activated because we convert headings to description tags
389    $self->{'description_tags'} = 1;
390
391    my $arrSections = [];
392    $$textref =~ s/<h([0-9]+)[^>]*>(.*?)<\/h[0-9]+>/$self->process_heading($1, $2, $arrSections, $upgraded_file)/isge;
393
394    if (scalar(@$arrSections)) {
395        my $strMetadata = $self->update_section_data($arrSections, -1);
396        if (length($strMetadata)) {
397        $strMetadata = '<!--' . $strMetadata . "\n-->\n</body>";
398        $$textref =~ s/<\/body>/$strMetadata/ig;
399        }
400    }
401    }
402
403    my $cursection = $doc_obj->get_top_section();
404
405    $self->extract_metadata ($textref, $metadata, $doc_obj, $cursection)
406    unless $self->{'no_metadata'} || $self->{'description_tags'};
407
408    # Store URL for page as metadata - this can be used for an
409    # altavista style search interface. The URL won't be valid
410    # unless the file structure contains the domain name (i.e.
411    # like when w3mir is used to download a website).
412
413    # URL metadata (even invalid ones) are used to support internal
414    # links, so even if 'file_is_url' is off, still need to store info
415
416    my ($tailname,$dirname) = &File::Basename::fileparse($upgraded_file);
417
418#    my $utf8_file = $self->filename_to_utf8_metadata($file);
419#    $utf8_file =~ s/&\#095;/_/g;
420    my $utf8_file = &unicode::raw_filename_to_url_encoded($tailname);
421
422
423    my $web_url = "http://";
424    if(defined $dirname) { # local directory
425        # Check for "ftp" in the domain name of the directory
426        #  structure to determine if this URL should be a ftp:// URL
427        # This check is not infallible, but better than omitting the
428        #  check, which would cause all files downloaded from ftp sites
429        #  via mirroring with wget to have potentially erroneous http:// URLs
430        #  assigned in their metadata
431        if ($dirname =~ /^[^\/]*ftp/i)
432    {
433      $web_url = "ftp://";
434    }
435    $dirname = $self->eval_dir_dots($dirname);
436    $dirname .= &util::get_dirsep() if $dirname ne ""; # if there's a directory, it should end on "/"
437    $web_url = $web_url.$dirname.$utf8_file;
438    } else {
439    $web_url = $web_url.$utf8_file;
440    }
441    $web_url =~ s/\\/\//g;
442
443    if ((defined $ENV{"DEBUG_UNICODE"}) && ($ENV{"DEBUG_UNICODE"})) {
444    print STDERR "******* upgraded_file:       $upgraded_file\n";
445    print STDERR "******* adding URL metadata: $utf8_file\n";
446    }
447
448
449    $doc_obj->add_utf8_metadata($cursection, "URL", $web_url);
450
451    if ($self->{'file_is_url'}) {
452    $doc_obj->add_metadata($cursection, "weblink", "<a href=\"$web_url\">");
453    $doc_obj->add_metadata($cursection, "webicon", "_iconworld_");
454    $doc_obj->add_metadata($cursection, "/weblink", "</a>");
455    }
456
457    if ($self->{'description_tags'}) {
458    # remove the html header - note that doing this here means any
459    # sections defined within the header will be lost (so all <Section>
460    # tags must appear within the body of the HTML)
461    my ($head_keep) = ($$textref =~ m/^(.*?)<body[^>]*>/is);
462
463    $$textref =~ s/^.*?<body[^>]*>//is;
464    $$textref =~ s/(<\/body[^>]*>|<\/html[^>]*>)//isg;
465
466    my $opencom = '(?:<!--|&lt;!(?:&mdash;|&#151;|--))';
467    my $closecom = '(?:-->|(?:&mdash;|&#151;|--)&gt;)';
468
469    my $lt = '(?:<|&lt;)';
470    my $gt = '(?:>|&gt;)';
471    my $quot = '(?:"|&quot;|&rdquo;|&ldquo;)';
472
473    my $dont_strip = '';
474    if ($self->{'no_strip_metadata_html'}) {
475        ($dont_strip = $self->{'no_strip_metadata_html'}) =~ s{,}{|}g;
476    }
477
478    my $found_something = 0; my $top = 1;
479    while ($$textref =~ s/^(.*?)$opencom(.*?)$closecom//s) {
480        my $text = $1;
481        my $comment = $2;
482        if (defined $text) {
483        # text before a comment - note that getting to here
484        # doesn't necessarily mean there are Section tags in
485        # the document
486        $self->process_section(\$text, $upgraded_base_dir, $upgraded_file, $doc_obj, $cursection);
487        }
488        while ($comment =~ s/$lt(.*?)$gt//s) {
489        my $tag = $1;
490        if ($tag eq "Section") {
491            $found_something = 1;
492            $cursection = $doc_obj->insert_section($doc_obj->get_end_child($cursection)) unless $top;
493            $top = 0;
494        } elsif ($tag eq "/Section") {
495            $found_something = 1;
496            $cursection = $doc_obj->get_parent_section ($cursection);
497        } elsif ($tag =~ m/^Metadata name=$quot(.*?)$quot/s) {
498            my $metaname = $1;
499            my $accumulate = $tag =~ m/mode=${quot}accumulate${quot}/ ? 1 : 0;
500            $comment =~ s/^(.*?)$lt\/Metadata$gt//s;
501            my $metavalue = $1;
502            $metavalue =~ s/^\s+//;
503            $metavalue =~ s/\s+$//;
504                    # assume that no metadata value intentionally includes
505                    # carriage returns or HTML tags (if they're there they
506                    # were probably introduced when converting to HTML from
507                    # some other format).
508            # actually some people want to have html tags in their
509            # metadata.
510            $metavalue =~ s/[\cJ\cM]/ /sg;
511            $metavalue =~ s/<[^>]+>//sg
512            unless $dont_strip && ($dont_strip eq 'all' || $metaname =~ m/^($dont_strip)$/);
513            $metavalue =~ s/\s+/ /sg;
514            if ($metaname =~ /\./) { # has a namespace
515            $metaname = "ex.$metaname";
516            }
517            if ($accumulate) {
518            $doc_obj->add_utf8_metadata($cursection, $metaname, $metavalue);
519            } else {
520            $doc_obj->set_utf8_metadata_element($cursection, $metaname, $metavalue);   
521            }
522        } elsif ($tag eq "Description" || $tag eq "/Description") {
523            # do nothing with containing Description tags
524        } else {
525            # simple HTML tag (probably created by the conversion
526            # to HTML from some other format) - we'll ignore it and
527            # hope for the best ;-)
528        }
529        }
530    }
531    if ($cursection ne "") {
532        print $outhandle "HTMLPlugin: WARNING: $upgraded_file contains unmatched <Section></Section> tags\n";
533    }
534
535    $$textref =~ s/^.*?<body[^>]*>//is;
536    $$textref =~ s/(<\/body[^>]*>|<\/html[^>]*>)//isg;
537    if ($$textref =~ m/\S/) {
538        if (!$found_something) {
539        if ($self->{'verbosity'} > 2) {
540            print $outhandle "HTMLPlugin: WARNING: $upgraded_file appears to contain no Section tags so\n";
541            print $outhandle "          will be processed as a single section document\n";
542        }
543
544        # go ahead and process single-section document
545        $self->process_section($textref, $upgraded_base_dir, $upgraded_file, $doc_obj, $cursection);
546
547        # if document contains no Section tags we'll go ahead
548        # and extract metadata (this won't have been done
549        # above as the -description_tags option prevents it)
550        my $complete_text = $head_keep.$doc_obj->get_text($cursection);
551        $self->extract_metadata (\$complete_text, $metadata, $doc_obj, $cursection)
552            unless $self->{'no_metadata'};
553
554        } else {
555        print $outhandle "HTMLPlugin: WARNING: $upgraded_file contains the following text outside\n";
556        print $outhandle "          of the final closing </Section> tag. This text will\n";
557        print $outhandle "          be ignored.";
558
559        my ($text);
560        if (length($$textref) > 30) {
561            $text = substr($$textref, 0, 30) . "...";
562        } else {
563            $text = $$textref;
564        }
565        $text =~ s/\n/ /isg;
566        print $outhandle " ($text)\n";
567        }
568    } elsif (!$found_something) {
569
570        if ($self->{'verbosity'} > 2) {
571        # may get to here if document contained no valid Section
572        # tags but did contain some comments. The text will have
573        # been processed already but we should print the warning
574        # as above and extract metadata
575        print $outhandle "HTMLPlugin: WARNING: $upgraded_file appears to contain no Section tags and\n";
576        print $outhandle "          is blank or empty.  Metadata will be assigned if present.\n";
577        }
578
579        my $complete_text = $head_keep.$doc_obj->get_text($cursection);
580        $self->extract_metadata (\$complete_text, $metadata, $doc_obj, $cursection)
581        unless $self->{'no_metadata'};
582    }
583   
584    } else {
585
586    # remove header and footer
587    if (!$self->{'keep_head'} || $self->{'description_tags'}) {
588        $$textref =~ s/^.*?<body[^>]*>//is;
589        $$textref =~ s/(<\/body[^>]*>|<\/html[^>]*>)//isg;
590    }
591
592    # single section document
593    $self->process_section($textref, $upgraded_base_dir, $upgraded_file, $doc_obj, $cursection);
594    }
595
596    return 1;
597}
598
599
600sub process_heading
601{
602    my ($self, $nHeadNo, $strHeadingText, $arrSections, $file) = @_;
603    $strHeadingText = '' if (!defined($strHeadingText));
604
605    my $strMetadata = $self->update_section_data($arrSections, int($nHeadNo));
606
607    my $strSecMetadata = '';
608    while ($strHeadingText =~ s/<!--gsdl-metadata(.*?)-->//is)
609    {
610    $strSecMetadata .= $1;
611    }
612
613    $strHeadingText =~ s/^\s+//g;
614    $strHeadingText =~ s/\s+$//g;
615    $strSecMetadata =~ s/^\s+//g;
616    $strSecMetadata =~ s/\s+$//g;
617
618    $strMetadata .= "\n<Section>\n\t<Description>\n\t\t<Metadata name=\"Title\">" . $strHeadingText . "</Metadata>\n";
619
620    if (length($strSecMetadata)) {
621    $strMetadata .= "\t\t" . $strSecMetadata . "\n";
622    }
623
624    $strMetadata .= "\t</Description>\n";
625
626    return "<!--" . $strMetadata . "-->";
627}
628
629
630sub update_section_data
631{
632    my ($self, $arrSections, $nCurTocNo) = @_;
633    my ($strBuffer, $nLast, $nSections) = ('', 0, scalar(@$arrSections));
634
635    if ($nSections == 0) {
636    push @$arrSections, $nCurTocNo;
637    return $strBuffer;
638    }
639    $nLast = $arrSections->[$nSections - 1];
640    if ($nCurTocNo > $nLast) {
641    push @$arrSections, $nCurTocNo;
642    return $strBuffer;
643    }
644    for(my $i = $nSections - 1; $i >= 0; $i--) {
645    if ($nCurTocNo <= $arrSections->[$i]) {
646        $strBuffer .= "\n</Section>";
647        pop @$arrSections;
648    }
649    }
650    push @$arrSections, $nCurTocNo;
651    return $strBuffer;
652}
653
654
655# note that process_section may be called multiple times for a single
656# section (relying on the fact that add_utf8_text appends the text to any
657# that may exist already).
658sub process_section {
659    my $self = shift (@_);
660    my ($textref, $base_dir, $file, $doc_obj, $cursection) = @_;
661    # trap links
662    if (!$self->{'nolinks'}) {
663    # usemap="./#index" not handled correctly => change to "#index"
664##  $$textref =~ s/(<img[^>]*?usemap\s*=\s*[\"\']?)([^\"\'>\s]+)([\"\']?[^>]*>)/
665
666    $$textref =~ s/(<img[^>]*?usemap\s*=\s*)((?:[\"][^\"]+[\"])|(?:[\'][^\']+[\'])|(?:[^\s\/>]+))([^>]*>)/
667        $self->replace_usemap_links($1, $2, $3)/isge;
668
669##  $$textref =~ s/(<(?:a|area|frame|link|script)\s+[^>]*?\s*(?:href|src)\s*=\s*[\"\']?)([^\"\'>\s]+)([\"\']?[^>]*>)/
670
671    $$textref =~ s/(<(?:a|area|frame|link|script)\s+[^>]*?\s*(?:href|src)\s*=\s*)((?:[\"][^\"]+[\"])|(?:[\'][^\']+[\'])|(?:[^\s\/>]+))([^>]*>)/
672        $self->replace_href_links ($1, $2, $3, $base_dir, $file, $doc_obj, $cursection)/isge;
673    }
674
675    # trap images
676
677    # Previously, by default, HTMLPlugin would embed <img> tags inside anchor tags
678    # i.e. <a href="image><img src="image"></a> in order to overcome a problem that
679    # turned regular text succeeding images into links. That is, by embedding <imgs>
680    # inside <a href=""></a>, the text following images were no longer misbehaving.
681    # However, there would be many occasions whereby images were not meant to link
682    # to their source images but where the images would link to another web page.
683    # To allow this, the no_image_links option was introduced: it would prevent
684    # the behaviour of embedding images into links that referenced the source images.
685
686    # Somewhere along the line, the problem of normal text turning into links when
687    # such text followed images which were not embedded in <a href=""></a> ceased
688    # to occur. This is why the following lines have been commented out (as well as
689    # two lines in replace_images). They appear to no longer apply.
690
691    # If at any time, there is a need for having images embedded in <a> anchor tags,
692    # then it might be better to turn that into an HTMLPlugin option rather than make
693    # it the default behaviour. Also, eventually, no_image_links needs to become
694    # a deprecated option for HTMLPlugin as it has now become the default behaviour.
695
696    #if(!$self->{'no_image_links'}){
697    $$textref =~ s/(<(?:img|embed|table|tr|td)[^>]*?(?:src|background)\s*=\s*)((?:[\"][^\"]+[\"])|(?:[\'][^\']+[\'])|(?:[^\s\/>]+))([^>]*>)/
698    $self->replace_images ($1, $2, $3, $base_dir, $file, $doc_obj, $cursection)/isge;
699    #}
700
701    # add text to document object
702    # turn \ into \\ so that the rest of greenstone doesn't think there
703    # is an escape code following. (Macro parsing loses them...)
704    $$textref =~ s/\\/\\\\/go;
705   
706    $doc_obj->add_utf8_text($cursection, $$textref);
707}
708
709sub replace_images {
710    my $self = shift (@_);
711    my ($front, $link, $back, $base_dir,
712    $file, $doc_obj, $section) = @_;
713
714    # remove quotes from link at start and end if necessary
715    if ($link=~/^[\"\']/) {
716    $link=~s/^[\"\']//;
717    $link=~s/[\"\']$//;
718    $front.='"';
719    $back="\"$back";
720    }
721
722    $link =~ s/\n/ /g;
723
724    # Hack to overcome Windows wv 0.7.1 bug that causes embedded images to be broken
725    # If the Word file path has spaces in it, wv messes up and you end up with
726    #   absolute paths for the images, and without the "file://" prefix
727    # So check for this special case and massage the data to be correct
728    if ($ENV{'GSDLOS'} =~ m/^windows/i && $self->{'plugin_type'} eq "WordPlug" && $link =~ m/^[A-Za-z]\:\\/) {
729    $link =~ s/^.*\\([^\\]+)$/$1/;
730    }
731   
732    my ($href, $hash_part, $rl) = $self->format_link ($link, $base_dir, $file);
733
734    my $img_file =  $self->add_file ($href, $rl, $hash_part, $base_dir, $doc_obj, $section);
735
736#    print STDERR "**** link = $link\n**** href = $href\n**** img_file = $img_file, rl = $rl\n";
737
738    my $anchor_name = $img_file;
739    #$anchor_name =~ s/^.*\///;
740    #$anchor_name = "<a name=\"$anchor_name\" ></a>";
741
742    my $image_link = $front . $img_file .$back;
743    return $image_link;
744
745    # The reasons for why the following two lines are no longer necessary can be
746    # found in subroutine process_section
747    #my $anchor_link = "<a href=\"$img_file\" >".$image_link."</a>"; 
748    #return $anchor_link;   
749   
750    #return $front . $img_file . $back . $anchor_name;
751}
752
753sub replace_href_links {
754    my $self = shift (@_);
755    my ($front, $link, $back, $base_dir, $file, $doc_obj, $section) = @_;
756
757    # remove quotes from link at start and end if necessary
758    if ($link=~/^[\"\']/) {
759    $link=~s/^[\"\']//;
760    $link=~s/[\"\']$//;
761    $front.='"';
762    $back="\"$back";
763    }
764
765    # attempt to sort out targets - frames are not handled
766    # well in this plugin and some cases will screw things
767    # up - e.g. the _parent target (so we'll just remove
768    # them all ;-)
769    $front =~ s/(target=\"?)_top(\"?)/$1_gsdltop_$2/is;
770    $back =~ s/(target=\"?)_top(\"?)/$1_gsdltop_$2/is;
771    $front =~ s/target=\"?_parent\"?//is;
772    $back =~ s/target=\"?_parent\"?//is;
773
774    return $front . $link . $back if $link =~ m/^\#/s;
775    $link =~ s/\n/ /g;
776
777    # Find file referred to by $link on file system
778    # This is more complicated than it sounds when char encodings
779    # is taken in to account
780    my ($href, $hash_part, $rl) = $self->format_link ($link, $base_dir, $file);
781 
782    # href may use '\'s where '/'s should be on Windows
783    $href =~ s/\\/\//g;
784    my ($filename) = $href =~ m/^(?:.*?):(?:\/\/)?(.*)/;
785   
786
787    ##### leave all these links alone (they won't be picked up by intermediate
788    ##### pages). I think that's safest when dealing with frames, targets etc.
789    ##### (at least until I think of a better way to do it). Problems occur with
790    ##### mailto links from within small frames, the intermediate page is displayed
791    ##### within that frame and can't be seen. There is still potential for this to
792    ##### happen even with html pages - the solution seems to be to somehow tell
793    ##### the browser from the server side to display the page being sent (i.e.
794    ##### the intermediate page) in the top level window - I'm not sure if that's
795    ##### possible - the following line should probably be deleted if that can be done
796    return $front . $link . $back if $href =~ m/^(mailto|news|gopher|nntp|telnet|javascript):/is;
797
798    if (($rl == 0) || ($filename =~ m/$self->{'process_exp'}/) ||
799    ($href =~ m/\/$/) || ($href =~ m/^(mailto|news|gopher|nntp|telnet|javascript):/i)) {
800
801    if ($ENV{'GSDLOS'} =~ m/^windows$/) {
802
803        # Don't do any encoding for now, as not clear what
804        # the right thing to do is to support filename
805        # encoding on Windows when they are not UTF16
806        #
807    }
808    else {
809        # => Unix-based system
810
811        # If web page didn't give encoding, then default to utf8
812        my $content_encoding= $self->{'content_encoding'} || "utf8";
813   
814        if ((defined $ENV{"DEBUG_UNICODE"}) && ($ENV{"DEBUG_UNICODE"})) {
815        print STDERR "**** Encoding with '$content_encoding', href: $href\n";
816        }
817
818        $href = encode($content_encoding,$href);
819    }
820
821    $href = &unicode::raw_filename_to_url_encoded($href);
822    $href = &unicode::filename_to_url($href);
823
824    &ghtml::urlsafe ($href);
825
826    if ((defined $ENV{"DEBUG_UNICODE"}) && ($ENV{"DEBUG_UNICODE"})) {
827        print STDERR "****** href=$href\n";   
828    }
829
830
831    return $front . "_httpextlink_&amp;rl=" . $rl . "&amp;href=" . $href . $hash_part . $back;
832    } else {
833    # link is to some other type of file (e.g., an image) so we'll
834    # need to associate that file
835    return $front . $self->add_file ($href, $rl, $hash_part, $base_dir, $doc_obj, $section) . $back;
836    }
837}
838
839sub add_file {
840    my $self = shift (@_);
841    my ($href, $rl, $hash_part, $base_dir, $doc_obj, $section) = @_;
842    my ($newname);
843
844    my $filename = $href;
845    if ($base_dir eq "") {
846    # remove http:/ thereby leaving one slash at the start
847    $filename =~ s/^[^:]*:\///;
848    }
849    else {
850    # remove http://
851    $filename =~ s/^[^:]*:\/\///;
852    }
853
854    $filename = &util::filename_cat($base_dir, $filename);
855
856    if (($self->{'use_realistic_book'}) || ($self->{'old_style_HDL'})) {
857    # we are processing a tidytmp file - want paths to be in import
858    $filename =~ s/([\\\/])tidytmp([\\\/])/$1import$2/;
859    }
860
861    # Replace %XX's in URL with decoded value if required. Note that the
862    # filename may include the %XX in some situations. If the *original*
863    # file's name was in URL encoding, the following method will not decode
864    # it.
865    my $utf8_filename = $filename;
866    my $opt_decode_utf8_filename = $self->opt_url_decode($utf8_filename);
867
868    my $content_encoding= $self->{'content_encoding'} || "utf8";
869
870    # The filenames that come through the HTML file have been decoded
871    # into Unicode aware Perl strings.  Need to convert them back
872    # to their initial raw-byte encoding to match the file that
873    # exists on the file system
874    $filename = encode($content_encoding, $opt_decode_utf8_filename);
875
876    # some special processing if the intended filename was converted to utf8, but
877    # the actual file still needs to be renamed
878    if (!&util::fd_exists($filename)) {
879    # try the original filename stored in map
880    if ((defined $ENV{"DEBUG_UNICODE"}) && ($ENV{"DEBUG_UNICODE"})) {
881        print STDERR "******!! orig filename did not exist: $filename\n";
882    }
883
884##  print STDERR "**** trying to look up utf8_filename: $utf8_filename\n";
885
886    my $original_filename = $self->{'utf8_to_original_filename'}->{$utf8_filename};
887
888    if ((defined $ENV{"DEBUG_UNICODE"}) && ($ENV{"DEBUG_UNICODE"})) {
889        print STDERR "******   From lookup utf8_filename, now trying for: $original_filename\n";
890    }
891
892    if (defined $original_filename && -e $original_filename) {
893        if ((defined $ENV{"DEBUG_UNICODE"}) && ($ENV{"DEBUG_UNICODE"})) {
894            print STDERR "******   Found match!\n";
895        }
896        $filename = $original_filename;
897    }
898    }
899   
900    my ($ext) = $filename =~ m/(\.[^\.]*)$/;
901
902    if ($rl == 0) {
903    if ((!defined $ext) || ($ext !~ m/$self->{'assoc_files'}/)) {
904        return "_httpextlink_&amp;rl=0&amp;el=prompt&amp;href=" . $href . $hash_part;
905    }
906    else {
907        return "_httpextlink_&amp;rl=0&amp;el=direct&amp;href=" . $href . $hash_part;
908    }
909    }
910
911    if ((!defined $ext) || ($ext !~ m/$self->{'assoc_files'}/)) {
912    return "_httpextlink_&amp;rl=" . $rl . "&amp;href=" . $href . $hash_part;
913    }
914    # add the original image file as a source file
915    if (!$self->{'processing_tmp_files'} ) {
916    $doc_obj->associate_source_file($filename);
917    }
918    if ($self->{'rename_assoc_files'}) {
919    if (defined $self->{'aux_files'}->{$href}) {
920        $newname = $self->{'aux_files'}->{$href}->{'dir_num'} . "/" .
921        $self->{'aux_files'}->{$href}->{'file_num'} . $ext;
922    } else {
923        $newname = $self->{'dir_num'} . "/" . $self->{'file_num'} . $ext;
924        $self->{'aux_files'}->{$href} = {'dir_num' => $self->{'dir_num'}, 'file_num' => $self->{'file_num'}};
925        $self->inc_filecount ();
926    }
927    $doc_obj->associate_file($filename, $newname, undef, $section);
928    return "_httpdocimg_/$newname";
929    } else {
930    if(&unicode::is_url_encoded($utf8_filename)) {
931        # use the possibly-decoded filename instead to avoid double URL encoding
932        ($newname) = $filename =~ m/([^\/\\]*)$/;
933    } else {
934        ($newname) = $utf8_filename =~ m/([^\/\\]*)$/;
935    }
936
937    # Make sure this name uses only ASCII characters.
938    # We use either base64 or URL encoding, as these preserve original encoding
939    $newname = &util::rename_file($newname, $self->{'file_rename_method'});
940
941### print STDERR "***** associating $filename (raw-byte/utf8)-> $newname\n";
942    $doc_obj->associate_file($filename, $newname, undef, $section);
943
944    # Since the generated image will be URL-encoded to avoid file-system/browser mess-ups
945    # of filenames, URL-encode the additional percent signs of the URL-encoded filename
946    my $newname_url = $newname;
947    $newname_url = &unicode::filename_to_url($newname_url);
948    return "_httpdocimg_/$newname_url";
949    }
950}
951
952
953sub format_link {
954    my $self = shift (@_);
955    my ($link, $base_dir, $file) = @_;
956
957    # strip off hash part, e.g. #foo, but watch out for any entities, e.g. &#x3B1;
958    my ($before_hash, $hash_part) = $link =~ m/^(.*?[^&])(\#.*)?$/;
959   
960    $hash_part = "" if !defined $hash_part;
961    if (!defined $before_hash || $before_hash !~ m/[\w\.\/]/) {
962    my $outhandle = $self->{'outhandle'};
963    print $outhandle "HTMLPlugin: ERROR - badly formatted tag ignored ($link)\n"
964        if $self->{'verbosity'};
965    return ($link, "", 0);
966    }
967
968    if ($before_hash =~ s@^((?:http|https|ftp|file|mms)://)@@i) {
969    my $type = $1;
970
971    if ($link =~ m/^(http|ftp):/i) {
972        # Turn url (using /) into file name (possibly using \ on windows)
973        my @http_dir_split = split('/', $before_hash);
974        $before_hash = &util::filename_cat(@http_dir_split);
975    }
976
977    $before_hash = $self->eval_dir_dots($before_hash);
978   
979    my $linkfilename = &util::filename_cat ($base_dir, $before_hash);
980   
981    my $rl = 0;
982    $rl = 1 if (-e $linkfilename);
983
984    # make sure there's a slash on the end if it's a directory
985    if ($before_hash !~ m/\/$/) {
986        $before_hash .= "/" if (-d $linkfilename);
987    }
988    return ($type . $before_hash, $hash_part, $rl);
989   
990    } elsif ($link !~ m/^(mailto|news|gopher|nntp|telnet|javascript):/i && $link !~ m/^\//) {
991
992    if ($before_hash =~ s@^/@@ || $before_hash =~ m/\\/) {
993
994        # the first directory will be the domain name if file_is_url
995        # to generate archives, otherwise we'll assume all files are
996        # from the same site and base_dir is the root
997
998        if ($self->{'file_is_url'}) {
999        my @dirs = split /[\/\\]/, $file;
1000        my $domname = shift (@dirs);
1001        $before_hash = &util::filename_cat($domname, $before_hash);
1002        $before_hash =~ s@\\@/@g; # for windows
1003        }
1004        else
1005        {
1006        # see if link shares directory with source document
1007        # => turn into relative link if this is so!
1008       
1009        if ($ENV{'GSDLOS'} =~ m/^windows/i) {
1010            # too difficult doing a pattern match with embedded '\'s...
1011            my $win_before_hash=$before_hash;
1012            $win_before_hash =~ s@(\\)+@/@g;
1013            # $base_dir is already similarly "converted" on windows.
1014            if ($win_before_hash =~ s@^$base_dir/@@o) {
1015            # if this is true, we removed a prefix
1016            $before_hash=$win_before_hash;
1017            }
1018        }
1019        else {
1020            # before_hash has lost leading slash by this point,
1021            # -> add back in prior to substitution with $base_dir
1022            $before_hash = "/$before_hash";
1023
1024            $before_hash = &util::filename_cat("",$before_hash);
1025            $before_hash =~ s@^$base_dir/@@;
1026        }
1027        }
1028    } else {
1029        # Turn relative file path into full path
1030        my $dirname = &File::Basename::dirname($file);
1031        $before_hash = &util::filename_cat($dirname, $before_hash);
1032        $before_hash = $self->eval_dir_dots($before_hash);             
1033    }
1034
1035    my $linkfilename = &util::filename_cat ($base_dir, $before_hash);
1036    # make sure there's a slash on the end if it's a directory
1037    if ($before_hash !~ m/\/$/) {
1038        $before_hash .= "/" if (-d $linkfilename);
1039    }
1040    return ("http://" . $before_hash, $hash_part, 1);
1041    } else {
1042    # mailto, news, nntp, telnet, javascript or gopher link
1043    return ($before_hash, "", 0);
1044    }
1045}
1046
1047sub extract_first_NNNN_characters {
1048    my $self = shift (@_);
1049    my ($textref, $doc_obj, $thissection) = @_;
1050   
1051    foreach my $size (split /,/, $self->{'first'}) {
1052    my $tmptext =  $$textref;
1053    # skip to the body
1054    $tmptext =~ s/.*<body[^>]*>//i;
1055    # remove javascript
1056    $tmptext =~ s@<script.*?</script>@ @sig;
1057    $tmptext =~ s/<[^>]*>/ /g;
1058    $tmptext =~ s/&nbsp;/ /g;
1059    $tmptext =~ s/^\s+//;
1060    $tmptext =~ s/\s+$//;
1061    $tmptext =~ s/\s+/ /gs;
1062    $tmptext = &unicode::substr ($tmptext, 0, $size);
1063    $tmptext =~ s/\s\S*$/&#8230;/; # adds an ellipse (...)
1064    $doc_obj->add_utf8_metadata ($thissection, "First$size", $tmptext);
1065    }
1066}
1067
1068
1069sub extract_metadata {
1070    my $self = shift (@_);
1071    my ($textref, $metadata, $doc_obj, $section) = @_;
1072    my $outhandle = $self->{'outhandle'};
1073    # if we don't want metadata, we may as well not be here ...
1074    return if (!defined $self->{'metadata_fields'});
1075   
1076    my $separator = $self->{'metadata_field_separator'};
1077    if ($separator eq "") {
1078    undef $separator;
1079    }
1080
1081    # metadata fields to extract/save. 'key' is the (lowercase) name of the
1082    # html meta, 'value' is the metadata name for greenstone to use
1083    my %find_fields = ();
1084
1085    my %creator_fields = (); # short-cut for lookups
1086
1087
1088    foreach my $field (split /,/, $self->{'metadata_fields'}) {
1089        $field =~ s/^\s+//; # remove leading whitespace
1090        $field =~ s/\s+$//; # remove trailing whitespace
1091   
1092    # support tag<tagname>
1093    if ($field =~ m/^(.*?)\s*<(.*?)>$/) {
1094        # "$2" is the user's preferred gs metadata name
1095        $find_fields{lc($1)}=$2; # lc = lowercase
1096    } else { # no <tagname> for mapping
1097        # "$field" is the user's preferred gs metadata name
1098        $find_fields{lc($field)}=$field; # lc = lowercase
1099    }
1100    }
1101
1102    if (defined $self->{'hunt_creator_metadata'} &&
1103    $self->{'hunt_creator_metadata'} == 1 ) {
1104    my @extra_fields =
1105        (
1106         'author',
1107         'author.email',
1108         'creator',
1109         'dc.creator',
1110         'dc.creator.corporatename',
1111         );
1112
1113    # add the creator_metadata fields to search for
1114    foreach my $field (@extra_fields) {
1115        $creator_fields{$field}=0; # add to lookup hash
1116    }
1117    }
1118
1119
1120    # find the header in the html file, which has the meta tags
1121    $$textref =~ m@<head>(.*?)</head>@si;
1122
1123    my $html_header=$1;
1124
1125    # go through every <meta... tag defined in the html and see if it is
1126    # one of the tags we want to match.
1127   
1128    # special case for title - we want to remember if its been found
1129    my $found_title = 0;
1130    # this assumes that ">" won't appear. (I don't think it's allowed to...)
1131    $html_header =~ m/^/; # match the start of the string, for \G assertion
1132   
1133    while ($html_header =~ m/\G.*?<meta(.*?)>/sig) {
1134    my $metatag=$1;
1135    my ($tag, $value);
1136
1137    # find the tag name
1138    $metatag =~ m/(?:name|http-equiv)\s*=\s*([\"\'])?(.*?)\1/is;
1139    $tag=$2;
1140    # in case they're not using " or ', but they should...
1141    if (! $tag) {
1142        $metatag =~ m/(?:name|http-equiv)\s*=\s*([^\s\>]+)/is;
1143        $tag=$1;
1144    }
1145
1146    if (!defined $tag) {
1147        print $outhandle "HTMLPlugin: can't find NAME in \"$metatag\"\n";
1148        next;
1149    }
1150   
1151    # don't need to assign this field if it was passed in from a previous
1152    # (recursive) plugin
1153    if (defined $metadata->{$tag}) {next}
1154
1155    # find the tag content
1156    $metatag =~ m/content\s*=\s*([\"\'])?(.*?)\1/is;
1157    $value=$2;
1158
1159    if (! $value) {
1160        $metatag =~ m/(?:name|http-equiv)\s*=\s*([^\s\>]+)/is;
1161        $value=$1;
1162    }
1163    if (!defined $value) {
1164        print $outhandle "HTMLPlugin: can't find VALUE in \"$metatag\"\n";
1165        next;
1166    }
1167   
1168    # clean up and add
1169    $value =~ s/\s+/ /gs;
1170    chomp($value); # remove trailing \n, if any
1171    if (exists $creator_fields{lc($tag)}) {
1172        # map this value onto greenstone's "Creator" metadata
1173        $tag='Creator';
1174    } elsif (!exists $find_fields{lc($tag)}) {
1175        next; # don't want this tag
1176    } else {
1177        # get the user's preferred capitalisation
1178        $tag = $find_fields{lc($tag)};
1179    }
1180    if (lc($tag) eq "title") {
1181        $found_title = 1;
1182    }
1183
1184    if ($self->{'verbosity'} > 2) {
1185        print $outhandle " extracted \"$tag\" metadata \"$value\"\n";
1186    }
1187
1188    if ($tag =~ /\./) {
1189        # there is a . so has a namespace, add ex.
1190        $tag = "ex.$tag";
1191    }
1192    if (defined $separator) {
1193        my @values = split($separator, $value);
1194        foreach my $v (@values) {
1195        $doc_obj->add_utf8_metadata($section, $tag, $v) if $v =~ /\S/;
1196        }
1197    }
1198    else {
1199        $doc_obj->add_utf8_metadata($section, $tag, $value);
1200    }
1201    }
1202   
1203    # TITLE: extract the document title
1204    if (exists $find_fields{'title'} && !$found_title) {
1205    # we want a title, and didn't find one in the meta tags
1206    # see if there's a <title> tag
1207    my $title;
1208    my $from = ""; # for debugging output only
1209    if ($html_header =~ m/<title[^>]*>([^<]+)<\/title[^>]*>/is) {
1210        $title = $1;
1211        $from = "<title> tags";
1212    }
1213
1214    if (!defined $title) {
1215        $from = "first 100 chars";
1216        # if no title use first 100 or so characters
1217        $title = $$textref;
1218        $title =~ s/^\xFE\xFF//; # Remove unicode byte order mark       
1219        $title =~ s/^.*?<body>//si;
1220        # ignore javascript!
1221        $title =~ s@<script.*?</script>@ @sig;
1222        $title =~ s/<\/([^>]+)><\1>//g; # (eg) </b><b> - no space
1223        $title =~ s/<[^>]*>/ /g; # remove all HTML tags
1224        $title = substr ($title, 0, 100);
1225        $title =~ s/\s\S*$/.../;
1226    }
1227    $title =~ s/<[^>]*>/ /g; # remove html tags
1228    $title =~ s/&nbsp;/ /g;
1229    $title =~ s/(?:&nbsp;|\xc2\xa0)/ /g; # utf-8 for nbsp...
1230    $title =~ s/\s+/ /gs; # collapse multiple spaces
1231    $title =~ s/^\s*//;   # remove leading spaces
1232    $title =~ s/\s*$//;   # remove trailing spaces
1233
1234    $title =~ s/^$self->{'title_sub'}// if ($self->{'title_sub'});
1235    $title =~ s/^\s+//s; # in case title_sub introduced any...
1236    $doc_obj->add_utf8_metadata ($section, "Title", $title);
1237    print $outhandle " extracted Title metadata \"$title\" from $from\n"
1238        if ($self->{'verbosity'} > 2);
1239    }
1240   
1241    # add FileFormat metadata
1242    $doc_obj->add_metadata($section,"FileFormat", "HTML");
1243
1244    # Special, for metadata names such as tagH1 - extracts
1245    # the text between the first <H1> and </H1> tags into "H1" metadata.
1246
1247    foreach my $field (keys %find_fields) {
1248    if ($field !~ m/^tag([a-z0-9]+)$/i) {next}
1249    my $tag = $1;
1250    if ($$textref =~ m@<$tag[^>]*>(.*?)</$tag[^>]*>@g) {
1251        my $content = $1;
1252        $content =~ s/&nbsp;/ /g;
1253        $content =~ s/<[^>]*>/ /g;
1254        $content =~ s/^\s+//;
1255        $content =~ s/\s+$//;
1256        $content =~ s/\s+/ /gs;
1257        if ($content) {
1258        $tag=$find_fields{"tag$tag"}; # get the user's capitalisation
1259        $tag =~ s/^tag//i;
1260        $doc_obj->add_utf8_metadata ($section, $tag, $content);
1261        print $outhandle " extracted \"$tag\" metadata \"$content\"\n"
1262            if ($self->{'verbosity'} > 2);
1263        }
1264    }
1265    }   
1266}
1267
1268
1269# evaluate any "../" to next directory up
1270# evaluate any "./" as here
1271sub eval_dir_dots {
1272    my $self = shift (@_);
1273    my ($filename) = @_;
1274    my $dirsep_os = &util::get_os_dirsep();
1275    my @dirsep = split(/$dirsep_os/,$filename);
1276
1277    my @eval_dirs = ();
1278    foreach my $d (@dirsep) {
1279    if ($d eq "..") {
1280        pop(@eval_dirs);
1281       
1282    } elsif ($d eq ".") {
1283        # do nothing!
1284
1285    } else {
1286        push(@eval_dirs,$d);
1287    }
1288    }
1289
1290    # Need to fiddle with number of elements in @eval_dirs if the
1291    # first one is the empty string.  This is because of a
1292    # modification to util::filename_cat that supresses the addition
1293    # of a leading '/' character (or \ if windows) (intended to help
1294    # filename cat with relative paths) if the first entry in the
1295    # array is the empty string.  Making the array start with *two*
1296    # empty strings is a way to defeat this "smart" option.
1297    #
1298    if (scalar(@eval_dirs) > 0) {
1299    if ($eval_dirs[0] eq ""){
1300        unshift(@eval_dirs,"");
1301    }
1302    }
1303   
1304    my $evaluated_filename = (scalar @eval_dirs > 0) ? &util::filename_cat(@eval_dirs) : "";
1305    return $evaluated_filename;
1306}
1307
1308sub replace_usemap_links {
1309    my $self = shift (@_);
1310    my ($front, $link, $back) = @_;
1311
1312    # remove quotes from link at start and end if necessary
1313    if ($link=~/^[\"\']/) {
1314    $link=~s/^[\"\']//;
1315    $link=~s/[\"\']$//;
1316    $front.='"';
1317    $back="\"$back";
1318    }
1319
1320    $link =~ s/^\.\///;
1321    return $front . $link . $back;
1322}
1323
1324sub inc_filecount {
1325    my $self = shift (@_);
1326
1327    if ($self->{'file_num'} == 1000) {
1328    $self->{'dir_num'} ++;
1329    $self->{'file_num'} = 0;
1330    } else {
1331    $self->{'file_num'} ++;
1332    }
1333}
1334
1335
1336# Extend read_file so that strings like &eacute; are
1337# converted to UTF8 internally. 
1338#
1339# We don't convert &lt; or &gt; or &amp; or &quot; in case
1340# they interfere with the GML files
1341
1342sub read_file {
1343    my $self = shift(@_);
1344    my ($filename, $encoding, $language, $textref) = @_;
1345
1346    $self->SUPER::read_file($filename, $encoding, $language, $textref);
1347
1348    # Convert entities to their Unicode code-point equivalents
1349    $$textref =~ s/&(lt|gt|amp|quot|nbsp);/&z$1;/go;
1350    $$textref =~ s/&([^;]+);/&ghtml::getcharequiv($1,1,1)/gseo;
1351    $$textref =~ s/&z(lt|gt|amp|quot|nbsp);/&$1;/go;
1352
1353}
1354
1355sub HB_read_html_file {
1356    my $self = shift (@_);
1357    my ($htmlfile, $text) = @_;
1358   
1359    # load in the file
1360    if (!open (FILE, $htmlfile)) {
1361    print STDERR "ERROR - could not open $htmlfile\n";
1362    return;
1363    }
1364
1365    my $foundbody = 0;
1366    $self->HB_gettext (\$foundbody, $text, "FILE");
1367    close FILE;
1368   
1369    # just in case there was no <body> tag
1370    if (!$foundbody) {
1371    $foundbody = 1;
1372    open (FILE, $htmlfile) || return;
1373    $self->HB_gettext (\$foundbody, $text, "FILE");
1374    close FILE;
1375    }
1376    # text is in utf8
1377}       
1378
1379# converts the text to utf8, as ghtml does that for &eacute; etc.
1380sub HB_gettext {
1381    my $self = shift (@_);
1382    my ($foundbody, $text, $handle) = @_;
1383   
1384    my $line = "";
1385    while (defined ($line = <$handle>)) {
1386    # look for body tag
1387    if (!$$foundbody) {
1388        if ($line =~ s/^.*<body[^>]*>//i) {
1389        $$foundbody = 1;
1390        } else {
1391        next;
1392        }
1393    }
1394   
1395    # check for symbol fonts
1396    if ($line =~ m/<font [^>]*?face\s*=\s*\"?(\w+)\"?/i) {
1397        my $font = $1;
1398        print STDERR "HBPlug::HB_gettext - warning removed font $font\n"
1399        if ($font !~ m/^arial$/i);
1400    }
1401
1402    $$text .= $line;
1403    }
1404
1405    if ($self->{'input_encoding'} eq "iso_8859_1") {
1406    # convert to utf-8
1407    $$text=&unicode::unicode2utf8(&unicode::convert2unicode("iso_8859_1", $text));
1408    }
1409    # convert any alphanumeric character entities to their utf-8
1410    # equivalent for indexing purposes
1411    #&ghtml::convertcharentities ($$text);
1412
1413    $$text =~ s/\s+/ /g; # remove \n's
1414
1415    # At this point $$text is a binary byte string
1416    # => turn it into a Unicode aware string, so full
1417    # Unicode aware pattern matching can be used.
1418    # For instance: 's/\x{0101}//g' or '[[:upper:]]'
1419    #
1420
1421    $$text = decode("utf8",$$text);
1422}
1423
1424sub HB_clean_section {
1425    my $self = shift (@_);
1426    my ($section) = @_;
1427
1428    # remove tags without a starting tag from the section
1429    my ($tag, $tagstart);
1430    while ($section =~ m/<\/([^>]{1,10})>/) {
1431    $tag = $1;
1432    $tagstart = index($section, "<$tag");
1433    last if (($tagstart >= 0) && ($tagstart < index($section, "<\/$tag")));
1434    $section =~ s/<\/$tag>//;
1435    }
1436   
1437    # remove extra paragraph tags
1438    while ($section =~ s/<p\b[^>]*>\s*<p\b/<p/ig) {}
1439   
1440    # remove extra stuff at the end of the section
1441    while ($section =~ s/(<u>|<i>|<b>|<p\b[^>]*>|&nbsp;|\s)$//i) {}
1442   
1443    # add a newline at the beginning of each paragraph
1444    $section =~ s/(.)\s*<p\b/$1\n\n<p/gi;
1445   
1446    # add a newline every 80 characters at a word boundary
1447    # Note: this regular expression puts a line feed before
1448    # the last word in each section, even when it is not
1449    # needed.
1450    $section =~ s/(.{1,80})\s/$1\n/g;
1451   
1452    # fix up the image links
1453    $section =~ s/<img[^>]*?src=\"?([^\">]+)\"?[^>]*>/
1454    <center><img src=\"$1\" \/><\/center><br\/>/ig;
1455    $section =~ s/&lt;&lt;I&gt;&gt;\s*([^\.]+\.(png|jpg|gif))/
1456    <center><img src=\"$1\" \/><\/center><br\/>/ig;
1457
1458    return $section;
1459}
1460
1461# Will convert the oldHDL format to the new HDL format (using the Section tag) 
1462sub convert_to_newHDLformat
1463{
1464    my $self = shift (@_);
1465    my ($file,$cnfile) = @_;
1466    my $input_filename = $file;
1467    my $tmp_filename = $cnfile;
1468   
1469    # write HTML tmp file with new HDL format
1470    open (PROD, ">$tmp_filename") || die("Error Writing to File: $tmp_filename $!");
1471   
1472    # read in the file and do basic html cleaning (removing header etc)
1473    my $html = "";
1474    $self->HB_read_html_file ($input_filename, \$html);
1475   
1476    # process the file one section at a time
1477    my $curtoclevel = 1;
1478    my $firstsection = 1;
1479    my $toclevel = 0;
1480    while (length ($html) > 0) {
1481    if ($html =~ s/^.*?(?:<p\b[^>]*>)?((<b>|<i>|<u>|\s)*)&lt;&lt;TOC(\d+)&gt;&gt;\s*(.*?)<p\b/<p/i) {
1482        $toclevel = $3;
1483        my $title = $4;
1484        my $sectiontext = "";
1485        if ($html =~ s/^(.*?)((?:<p\b[^>]*>)?((<b>|<i>|<u>|\s)*)&lt;&lt;TOC\d+&gt;&gt;)/$2/i) {
1486        $sectiontext = $1;
1487        } else {
1488        $sectiontext = $html;
1489        $html = "";
1490        }
1491
1492        # remove tags and extra spaces from the title
1493        $title =~ s/<\/?[^>]+>//g;
1494        $title =~ s/^\s+|\s+$//g;
1495
1496        # close any sections below the current level and
1497        # create a new section (special case for the firstsection)
1498        print PROD "<!--\n";
1499        while (($curtoclevel > $toclevel) ||
1500           (!$firstsection && $curtoclevel == $toclevel)) {
1501        $curtoclevel--;
1502        print PROD "</Section>\n";
1503        }
1504        if ($curtoclevel+1 < $toclevel) {
1505        print STDERR "WARNING - jump in toc levels in $input_filename " .
1506            "from $curtoclevel to $toclevel\n";
1507        }
1508        while ($curtoclevel < $toclevel) {
1509        $curtoclevel++;
1510        }
1511
1512        if ($curtoclevel == 1) {
1513            # add the header tag
1514        print PROD "-->\n";
1515            print PROD "<HTML>\n<HEAD>\n<TITLE>$title</TITLE>\n</HEAD>\n<BODY>\n";
1516        print PROD "<!--\n";
1517        }
1518       
1519        print PROD "<Section>\n\t<Description>\n\t\t<Metadata name=\"Title\">$title</Metadata>\n\t</Description>\n";
1520       
1521        print PROD "-->\n";
1522       
1523        # clean up the section html
1524        $sectiontext = $self->HB_clean_section($sectiontext);
1525
1526        print PROD "$sectiontext\n";     
1527
1528    } else {
1529        print STDERR "WARNING - leftover text\n" , $self->shorten($html),
1530        "\nin $input_filename\n";
1531        last;
1532    }
1533    $firstsection = 0;
1534    }
1535   
1536    print PROD "<!--\n";
1537    while ($curtoclevel > 0) {
1538    $curtoclevel--;
1539    print PROD "</Section>\n";
1540    }
1541    print PROD "-->\n";
1542   
1543    close (PROD) || die("Error Closing File: $tmp_filename $!");
1544   
1545    return $tmp_filename;
1546}       
1547
1548sub shorten {
1549    my $self = shift (@_);
1550    my ($text) = @_;
1551
1552    return "\"$text\"" if (length($text) < 100);
1553
1554    return "\"" . substr ($text, 0, 50) . "\" ... \"" .
1555    substr ($text, length($text)-50) . "\"";
1556}
1557
1558sub convert_tidy_or_oldHDL_file
1559{
1560    my $self = shift (@_);
1561    my ($file) = @_;
1562    my $input_filename = $file;
1563   
1564    if (-d $input_filename)
1565    {
1566        return $input_filename;
1567    }
1568   
1569    # get the input filename
1570    my ($tailname, $dirname, $suffix) = &File::Basename::fileparse($input_filename, "\\.[^\\.]+\$");
1571    my $base_dirname = $dirname;
1572    $suffix = lc($suffix);   
1573   
1574    # derive tmp filename from input filename
1575    # Remove any white space from filename -- no risk of name collision, and
1576    # makes later conversion by utils simpler. Leave spaces in path...
1577    # tidy up the filename with space, dot, hyphen between
1578    $tailname =~ s/\s+//g;
1579    $tailname =~ s/\.+//g;
1580    $tailname =~ s/\-+//g;
1581    # convert to utf-8 otherwise we have problems with the doc.xml file
1582    # later on
1583    &unicode::ensure_utf8(\$tailname);
1584   
1585    # softlink to collection tmp dir
1586    my $tmp_dirname = &util::filename_cat($ENV{'GSDLCOLLECTDIR'}, "tidytmp");
1587    &util::mk_dir($tmp_dirname) if (!-e $tmp_dirname);
1588   
1589    my $test_dirname = "";
1590    my $f_separator = &util::get_os_dirsep();
1591   
1592    if ($dirname =~ m/import$f_separator/)
1593    {
1594        $test_dirname = $'; #'
1595   
1596    #print STDERR "init $'\n";
1597   
1598    while ($test_dirname =~ m/[$f_separator]/)
1599    {
1600        my $folderdirname = $`;
1601        $tmp_dirname = &util::filename_cat($tmp_dirname,$folderdirname);
1602        &util::mk_dir($tmp_dirname) if (!-e $tmp_dirname);
1603        $test_dirname = $'; #'
1604    }
1605    }
1606   
1607    my $tmp_filename = &util::filename_cat($tmp_dirname, "$tailname$suffix");
1608   
1609    # tidy or convert the input file if it is a HTML-like file or it is accepted by the process_exp
1610    if (($suffix eq ".htm") || ($suffix eq ".html") || ($suffix eq ".shtml"))
1611    {   
1612        #convert the input file to a new style HDL
1613        my $hdl_output_filename = $input_filename;
1614        if ($self->{'old_style_HDL'})
1615        {
1616        $hdl_output_filename = &util::filename_cat($tmp_dirname, "$tailname$suffix");
1617        $hdl_output_filename = $self->convert_to_newHDLformat($input_filename,$hdl_output_filename);
1618        }
1619   
1620    #just for checking copy all other file from the base dir to tmp dir if it is not exists
1621    opendir(DIR,$base_dirname) or die "Can't open base directory : $base_dirname!";
1622    my @files = grep {!/^\.+$/} readdir(DIR);
1623    close(DIR);
1624
1625    foreach my $file (@files)
1626    {
1627        my $src_file = &util::filename_cat($base_dirname,$file);
1628        my $dest_file = &util::filename_cat($tmp_dirname,$file);
1629        if ((!-e $dest_file) && (!-d $src_file))
1630        {
1631        # just copy the original file back to the tmp directory
1632        copy($src_file,$dest_file) or die "Can't copy file $src_file to $dest_file $!";
1633        }
1634    }
1635   
1636    # tidy the input file
1637    my $tidy_output_filename = $hdl_output_filename;
1638    if ($self->{'use_realistic_book'})
1639    {
1640        $tidy_output_filename = &util::filename_cat($tmp_dirname, "$tailname$suffix");
1641        $tidy_output_filename = $self->tmp_tidy_file($hdl_output_filename,$tidy_output_filename);
1642    }
1643    $tmp_filename = $tidy_output_filename;
1644    }
1645    else
1646    {
1647        if (!-e $tmp_filename)
1648    {
1649        # just copy the original file back to the tmp directory
1650        copy($input_filename,$tmp_filename) or die "Can't copy file $input_filename to $tmp_filename $!";
1651    }
1652    }
1653   
1654    return $tmp_filename;
1655}
1656
1657
1658# Will make the html input file as a proper XML file with removed font tag and
1659# image size added to the img tag.
1660# The tidying process takes place in a collection specific 'tmp' directory so
1661# that we don't accidentally damage the input.
1662sub tmp_tidy_file
1663{
1664    my $self = shift (@_);
1665    my ($file,$cnfile) = @_;
1666    my $input_filename = $file;
1667    my $tmp_filename = $cnfile;
1668   
1669    # get the input filename
1670    my ($tailname, $dirname, $suffix) = &File::Basename::fileparse($input_filename, "\\.[^\\.]+\$");
1671
1672    require HTML::TokeParser::Simple;
1673   
1674    # create HTML parser to decode the input file
1675    my $parser = HTML::TokeParser::Simple->new($input_filename);
1676
1677    # write HTML tmp file without the font tag and image size are added to the img tag
1678    open (PROD, ">$tmp_filename") || die("Error Writing to File: $tmp_filename $!");
1679    while (my $token = $parser->get_token())
1680    {
1681    # is it an img tag
1682    if ($token->is_start_tag('img'))
1683    {
1684        # get the attributes
1685        my $attr = $token->return_attr;
1686
1687        # get the full path to the image
1688        my $img_file = &util::filename_cat($dirname,$attr->{src});
1689       
1690        # set the width and height attribute
1691        ($attr->{width}, $attr->{height}) = imgsize($img_file);
1692
1693        # recreate the tag
1694        print PROD "<img";
1695        print PROD map { qq { $_="$attr->{$_}"} } keys %$attr;
1696        print PROD ">";
1697    }
1698    # is it a font tag
1699    else
1700    {
1701        if (($token->is_start_tag('font')) || ($token->is_end_tag('font')))
1702        {
1703        # remove font tag
1704        print PROD "";
1705        }
1706        else
1707        {
1708        # print without changes
1709        print PROD $token->as_is;
1710        }
1711    }
1712    }
1713    close (PROD) || die("Error Closing File: $tmp_filename $!");
1714
1715    # run html-tidy on the tmp file to make it a proper XML file
1716
1717    my $outhandle = $self->{'outhandle'};
1718    print $outhandle "Converting HTML to be XML compliant:\n";
1719
1720    my $tidy_cmd = "tidy";
1721    $tidy_cmd .= " -q" if ($self->{'verbosity'} <= 2);
1722    $tidy_cmd .= " -raw -wrap 0 -asxml \"$tmp_filename\"";
1723    if ($self->{'verbosity'} <= 2) {
1724    if ($ENV{'GSDLOS'} =~ m/^windows/i) {
1725        $tidy_cmd .= " 2>nul";
1726    }
1727    else {
1728        $tidy_cmd .= " 2>/dev/null";
1729    }
1730    print $outhandle "  => $tidy_cmd\n";
1731    }
1732
1733    my $tidyfile = `$tidy_cmd`;
1734
1735    # write result back to the tmp file
1736    open (PROD, ">$tmp_filename") || die("Error Writing to File: $tmp_filename $!");
1737    print PROD $tidyfile;
1738    close (PROD) || die("Error Closing File: $tmp_filename $!");
1739   
1740    # return the output filename
1741    return $tmp_filename;
1742}
1743
1744sub associate_cover_image
1745{
1746    my $self = shift(@_);
1747    my ($doc_obj, $filename) = @_;
1748    if (($self->{'use_realistic_book'}) || ($self->{'old_style_HDL'}))
1749    {
1750    # we will have cover image in tidytmp, but want it from import
1751    $filename =~ s/([\\\/])tidytmp([\\\/])/$1import$2/;
1752    }
1753    $self->SUPER::associate_cover_image($doc_obj, $filename);
1754}
1755
1756   
17571;
Note: See TracBrowser for help on using the browser.