source: trunk/gsdl/perllib/plugins/GMLPlug.pm@ 2795

Last change on this file since 2795 was 2795, checked in by sjboddie, 23 years ago

Got ZIPPlug working under under windows

  • Property svn:executable set to *
  • Property svn:keywords set to Author Date Id Revision
File size: 6.2 KB
Line 
1###########################################################################
2#
3# GMLPlug.pm --
4# A component of the Greenstone digital library software
5# from the New Zealand Digital Library Project at the
6# University of Waikato, New Zealand.
7#
8# Copyright (C) 1999 New Zealand Digital Library Project
9#
10# This program is free software; you can redistribute it and/or modify
11# it under the terms of the GNU General Public License as published by
12# the Free Software Foundation; either version 2 of the License, or
13# (at your option) any later version.
14#
15# This program is distributed in the hope that it will be useful,
16# but WITHOUT ANY WARRANTY; without even the implied warranty of
17# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18# GNU General Public License for more details.
19#
20# You should have received a copy of the GNU General Public License
21# along with this program; if not, write to the Free Software
22# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
23#
24###########################################################################
25
26# plugin which processes a GML format document
27# assumes that gml tags are all in lower-case.
28
29package GMLPlug;
30
31use BasPlug;
32use util;
33use doc;
34
35sub BEGIN {
36 @ISA = ('BasPlug');
37}
38
39sub new {
40 my ($class) = @_;
41 my $self = new BasPlug ("GMLPlug", @_);
42
43 return bless $self, $class;}
44
45sub get_default_process_exp {
46 my $self = shift (@_);
47
48 return q^(?i)\.gml?$^;
49}
50
51# return number of files processed, undef if can't process
52# Note that $base_dir might be "" and that $file might
53# include directories
54sub read {
55 my $self = shift (@_);
56 my ($pluginfo, $base_dir, $file, $metadata, $processor, $maxdocs) = @_;
57 my $outhandle = $self->{'outhandle'};
58
59 my $filename = $file;
60 $filename = &util::filename_cat ($base_dir, $file) if $base_dir =~ /\w/;
61
62 return 0 if $self->{'block_exp'} ne "" && $filename =~ /$self->{'block_exp'}/;
63 if ($filename !~ /$self->{'process_exp'}/ || !-f $filename) {
64 return undef;
65 }
66 $file =~ s/^[\/\\]+//; # $file often begins with / so we'll tidy it up
67
68 print $outhandle "GMLPlug: processing $file\n";
69
70 my $parent_dir = $file;
71 $parent_dir =~ s/[^\\\/]*$//;
72 $parent_dir = &util::filename_cat ($base_dir, $parent_dir);
73
74 if (!open (INFILE, $filename)) {
75 print $outhandle "GMLPlug::read - couldn't read $filename\n";
76 return 0;
77 }
78
79 undef $/;
80 my $gml = <INFILE>;
81 $/ = "\n";
82 close (INFILE);
83
84 my @gml_sections = split("</gsdlsection>",$gml);
85 $gml = shift(@gml_sections);
86
87 my $no_docs = 0;
88
89 while (1) {
90 # create a new document
91 my $doc_obj = new doc ();
92 my $section = $doc_obj->get_top_section();
93
94 # process the document
95 my $firstsection = 1;
96 while (1) {
97 my ($tags, $text) = ("", "");
98
99 my @indenting_sections = split("<gsdlsection", $gml);
100 shift(@indenting_sections); # skips over xml header if present
101
102 foreach $gml (@indenting_sections) {
103
104 if ($gml =~ /^\s*([^>]*)>(.*)$/so) {
105 $tags = $1 if defined $1;
106 $text = &GMLPlug::_unescape_text($2);
107
108 } else {
109 print $outhandle "GMLPlug::read - error in file $filename\n";
110 print $outhandle "text: \"$gml\"\n";
111 last;
112 }
113
114 # create the section (unless this is the first section)
115 if ($firstsection) {
116 $firstsection = 0;
117# $tags =~ /gsdlsourcefilename\s*=\s*(?:\"([^\"]*)\")/o;
118# $src_filename = $2 || $3;
119
120 } else {
121
122 $tags =~ s/gsdlnum\s*=\s*\"?(\d+)\"?//o;
123 if (defined $1) {
124 $section .= ".$1";
125 $doc_obj->create_named_section($section);
126 } else {
127 $section = $doc_obj->insert_section($doc_obj->get_end_child($section));
128 }
129 }
130
131 # add the metadata
132 # could be stored as either attributes or ....
133 while ((defined $tags) && ($tags =~ s/^\s*(\S+)=\"([^\"]*)\"//o)) {
134 $doc_obj->add_utf8_metadata($section, $1, &GMLPlug::_unescape_text($2))
135 if (defined $1 and defined $2);
136
137 }
138
139 # ... or tags (xml compliant)
140 if ($text =~ m/^\s*<metadata>/)
141 {
142 my ($metadata, $tagname, $tagvalue);
143 ($metadata,$text)
144 = ($text =~ m/\s*<metadata>\s*(<.*)\s*<\/metadata>(.*)$/s);
145
146 # note: \1 refers to 1st match within regexp, so we can
147 # handle the unescaped text here...
148 while ((defined $metadata)
149 && ($metadata =~ s/<(.*?)>(.*?)<\/\1>//s))
150 {
151 if (defined $1 && defined $2)
152 {
153 $tagname = $1;
154 $tagvalue = $2;
155
156 # if tagname begins with '/' it will be escaped
157 $tagname =~ s/^&\#47;/\//;
158
159 $doc_obj->add_utf8_metadata($section, $tagname, &GMLPlug::_unescape_text($tagvalue));
160 }
161 }
162 }
163
164 # add the text
165
166 $doc_obj->add_utf8_text($section, $text)
167 if ((defined $text) && ($text ne ""));
168 }
169
170 $gml = shift(@gml_sections); # get next bit of data
171 last unless defined $gml;
172 last if $section eq ""; # back to top level again (more than one document in gml file)
173 $section = $doc_obj->get_parent_section ($section);
174 } # while (1) section level
175
176 # add the associated files
177 my $assoc_files = $doc_obj->get_metadata($doc_obj->get_top_section(), "gsdlassocfile");
178 my ($assoc_file_info);
179
180 foreach $assoc_file_info (@$assoc_files)
181 {
182 my ($assoc_file, $mime_type, $dir) = split (":", $assoc_file_info);
183 my $real_dir = &util::filename_cat($parent_dir, $assoc_file),
184 my $assoc_dir = (defined $dir && $dir ne "")
185 ? &util::filename_cat($dir, $assoc_file) : $assoc_file;
186 $doc_obj->associate_file($real_dir, $assoc_dir, $mime_type);
187
188 }
189 $doc_obj->delete_metadata($doc_obj->get_top_section(), "gsdlassocfile");
190
191 # add metadata passed in from elsewhere
192 $self->extra_metadata ($doc_obj, $doc_obj->get_top_section(), $metadata);
193
194 # do any automatic metadata extraction
195 $self->auto_extract_metadata ($doc_obj);
196
197 # assume the document has an OID already
198
199 # process the document
200 $processor->process($doc_obj, $file);
201
202 $no_docs++;
203 last if ($maxdocs > -1 && $no_docs >= $maxdocs);
204 last unless defined $gml && $gml =~ /\w/;
205 } # while(1) document level
206
207 return $no_docs; # no of docs processed
208}
209
210sub _unescape_text {
211 my ($text) = @_;
212
213 # special characters in the gml encoding
214 $text =~ s/&lt;/</g;
215 $text =~ s/&gt;/>/g;
216 $text =~ s/&quot;/\"/g;
217 $text =~ s/&amp;/&/g; # this has to be last...
218
219 return $text;
220}
221
2221;
Note: See TracBrowser for help on using the repository browser.