Context Navigation

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

Last change on this file since 31446 was 31446, checked in by ak19, 7 years ago
use guess_filesystem_encoding instead of utf8 hard coded. hope it works back on linux, and on mac!
Property svn:executable set to ``* Property svn:keywords set to `Author Date Id Revision`
File size: 70.1 KB

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

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

Download in other formats: