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

Last change on this file since 707 was 707, checked in by sjboddie, 25 years ago

fixed a windows specific bug

  • Property svn:executable set to *
  • Property svn:keywords set to Author Date Id Revision
File size: 4.8 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
28package GMLPlug;
29
30use html;
31use BasPlug;
32use util;
33use doc;
34
35
36sub BEGIN {
37 @ISA = ('BasPlug');
38}
39
40sub new {
41 my ($class) = @_;
42 $self = new BasPlug ();
43
44 return bless $self, $class;
45}
46
47sub is_recursive {
48 my $self = shift (@_);
49
50 return 0; # this is not a recursive plugin
51}
52
53sub _unescape_text {
54 my ($text) = @_;
55
56 # special characters in the gml encoding
57 $text =~ s/&lt;/</g;
58 $text =~ s/&gt;/>/g;
59 $text =~ s/&quot;/\"/g;
60 $text =~ s/&amp;/&/g; # this has to be last...
61
62 return $text;
63}
64
65# return number of files processed, undef if can't process
66# Note that $base_dir might be "" and that $file might
67# include directories
68sub read {
69 my $self = shift (@_);
70 my ($pluginfo, $base_dir, $file, $metadata, $processor) = @_;
71 my $fullname = &util::filename_cat ($base_dir, $file);
72
73 # see if this is a gml book
74 return undef unless (-f $fullname && $fullname =~ /\.gml(\.gz)?$/i);
75
76 my ($parent_dir, $gz) = $fullname =~ /^(.*?)[\/\\][^\/\\]+.gml(\.gz)?$/i;
77
78 if (defined $gz && $gz =~ /\.gz/i) {
79 $gz = 1;
80 } else {
81 $gz = 0;
82 }
83
84 # create a new document
85 my $doc_obj = new doc ();
86 my $section = $doc_obj->get_top_section();
87
88 print STDERR "GMLPlug: processing $file\n";
89
90 # read in the document
91 my $gml = "";
92 my $line = "";
93
94 if ($gz) {
95 if (!open (INFILE, "zcat $fullname |")) {
96 print STDERR "GMLPlug::read - zcat couldn't read $fullname\n";
97 return undef;
98 }
99 } else {
100 if (!open (INFILE, $fullname)) {
101 print STDERR "GMLPlug::read - couldn't read $fullname\n";
102 return undef;
103 }
104 }
105
106 while (defined ($line = <INFILE>)) {
107 $gml .= $line;
108 }
109 close (INFILE);
110
111 # process the document
112 my $firstsection = 1;
113 while ($gml =~ /\S/) {
114 if ($gml =~ s/^\s*<gsdlsection([^>]*)>(.*?)(<\/?gsdlsection)/$3/is) {
115 my $tags = $1;
116 $tags = "" unless defined $tags;
117 my $text = &_unescape_text($2);
118
119 # create the section (unless this is the first section)
120 if (!$firstsection) {
121 $tags =~ s/gsdlnum\s*=\s*\"?(\d+)\"?//i;
122 if (defined $1) {
123 $section .= ".$1";
124 $doc_obj->create_named_section($section);
125 } else {
126 $section = $doc_obj->insert_section($doc_obj->get_end_child($section));
127 }
128 }
129 $firstsection = 0;
130
131 # add the tags
132 while ((defined $tags) && ($tags =~ s/^\s*(\w+)\s*=\s*\"([^\"]*)\"//)) {
133 $doc_obj->add_utf8_metadata($section, $1 , &_unescape_text($2))
134 if (defined $1 and defined $2);
135 }
136
137 # add the text
138 $doc_obj->add_utf8_text($section, $text)
139 if ((defined $text) && ($text ne ""));
140
141 } elsif ($gml =~ s/^\s*<\/gsdlsection>//) {
142 $section = $doc_obj->get_parent_section ($section);
143
144 } else {
145 print STDERR "GMLPlug::read - error in file $fullname\n";
146 print STDERR "text: \"$gml\"\n";
147 last;
148 }
149 }
150
151 # add the associated files
152 $assoc_files = $doc_obj->get_metadata($doc_obj->get_top_section(), "gsdlassocfile");
153 my ($assoc_file_info);
154 foreach $assoc_file_info (@$assoc_files) {
155 my ($assoc_file, $mime_type) = split (":", $assoc_file_info);
156 $doc_obj->associate_file(&util::filename_cat($parent_dir, $assoc_file),
157 $assoc_file, $mime_type);
158
159 }
160 $doc_obj->delete_metadata($doc_obj->get_top_section(), "gsdlassocfile");
161
162 # add metadata
163 foreach $field (keys(%$metadata)) {
164 # $metadata->{$field} may be an array reference
165 if (ref ($metadata->{$field}) eq "ARRAY") {
166 map {
167 $doc_obj->add_metadata ($doc_obj->get_top_section(), $field, $_);
168 } @{$metadata->{$field}};
169 } else {
170 $doc_obj->add_metadata ($doc_obj->get_top_section(), $field, $metadata->{$field});
171 }
172 }
173
174
175 # assume the document has an OID
176
177 # process the document
178 $processor->process($doc_obj, $file);
179
180 return 1; # processed the file
181}
182
183
1841;
Note: See TracBrowser for help on using the repository browser.