Context Navigation

source: main/trunk/greenstone2/perllib/plugins/HTMLPlugin.pm@ 28782

Last change on this file since 28782 was 28319, checked in by ak19, 11 years ago
The replace-with-src-doc feature had stopped working. It needed Image/Size.pm, so INC needs to be updated in HTMLPlugin to include perllib/cpan for this.
Property svn:executable set to ``* Property svn:keywords set to `Author Date Id Revision`
File size: 66.3 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats: