Add Ubuntu raring, Debian jessie
[simpleserver-moved-to-github.git] / GRS1.pm
1 ## This file is part of simpleserver
2 ## Copyright (C) 2000-2013 Index Data.
3 ## All rights reserved.
4 ## Redistribution and use in source and binary forms, with or without
5 ## modification, are permitted provided that the following conditions are met:
6 ##
7 ##     * Redistributions of source code must retain the above copyright
8 ##       notice, this list of conditions and the following disclaimer.
9 ##     * Redistributions in binary form must reproduce the above copyright
10 ##       notice, this list of conditions and the following disclaimer in the
11 ##       documentation and/or other materials provided with the distribution.
12 ##     * Neither the name of Index Data nor the names of its contributors
13 ##       may be used to endorse or promote products derived from this
14 ##       software without specific prior written permission.
15 ##
16 ## THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY
17 ## EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
18 ## WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
19 ## DISCLAIMED. IN NO EVENT SHALL THE REGENTS AND CONTRIBUTORS BE LIABLE FOR ANY
20 ## DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
21 ## (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
22 ## LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
23 ## ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
24 ## (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
25 ## THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
26
27 package Net::Z3950::GRS1;
28
29 use strict;
30 use IO::Handle;
31 use Carp;
32
33 sub new {
34         my ($class, $href, $map) = @_;
35         my $self = {};
36
37         $self->{ELEMENTS} = [];
38         $self->{FH} = *STDOUT;                          ## Default output handle is STDOUT
39         $self->{MAP} = $map;
40         bless $self, $class;
41         if (defined($href) && ref($href) eq 'HASH') {
42                 if (!defined($map)) {
43                         croak 'Usage: new Net::Z3950::GRS1($href, $map);';
44                 }
45                 $self->Hash2grs($href, $map);
46         }
47
48         return $self;
49 }
50
51
52 sub Hash2grs {
53         my ($self, $href, $mapping) = @_;
54         my $key;
55         my $content;
56         my $aref;
57         my $issue;
58
59         $mapping = defined($mapping) ? $mapping : $self->{MAP};
60         $self->{MAP} = $mapping;
61         foreach $key (keys %$href) {
62                 $content = $href->{$key};
63                 next unless defined($content);
64                 if (!defined($aref = $mapping->{$key})) {
65                         print STDERR "Hash2grs: Unmapped key: '$key'\n";
66                         next;
67                 }
68                 if (ref($content) eq 'HASH') {                                  ## Subtree?
69                         my $subtree = new Net::Z3950::GRS1($content, $mapping);
70                         $self->AddElement($aref->[0], $aref->[1], &Net::Z3950::GRS1::ElementData::Subtree, $subtree);
71                 } elsif (!ref($content)) {                                      ## Regular string?
72                         $self->AddElement($aref->[0], $aref->[1], &Net::Z3950::GRS1::ElementData::String, $content);
73                 } elsif (ref($content) eq 'ARRAY') {
74                         my $issues = new Net::Z3950::GRS1;
75                         foreach $issue (@$content) {
76                                 my $entry = new Net::Z3950::GRS1($issue, $mapping);
77                                 $issues->AddElement(5, 1, &Net::Z3950::GRS1::ElementData::Subtree, $entry);
78                         }
79                         $self->AddElement($aref->[0], $aref->[1], &Net::Z3950::GRS1::ElementData::Subtree, $issues);
80                 } else {
81                         print STDERR "Hash2grs: Unsupported content type\n";
82                         next;
83                 }
84         }
85 }
86
87
88 sub GetElementList {
89         my $self = shift;
90
91         return $self->{ELEMENTS};
92 }
93
94
95 sub CreateTaggedElement {
96         my ($self, $type, $value, $element_data) = @_;
97         my $tagged = {};
98
99         $tagged->{TYPE} = $type;
100         $tagged->{VALUE} = $value;
101         $tagged->{OCCURANCE} = undef;
102         $tagged->{META} = undef;
103         $tagged->{VARIANT} = undef;
104         $tagged->{ELEMENTDATA} = $element_data;
105
106         return $tagged;
107 }
108
109
110 sub GetTypeValue {
111         my ($self, $TaggedElement) = @_;
112
113         return ($TaggedElement->{TYPE}, $TaggedElement->{VALUE});
114 }
115
116
117 sub GetElementData {
118         my ($self, $TaggedElement) = @_;
119
120         return $TaggedElement->{ELEMENTDATA};
121 }
122
123
124 sub CheckTypes {
125         my ($self, $which, $content) = @_;
126
127         if ($which == &Net::Z3950::GRS1::ElementData::String) {
128                 if (ref($content) eq '') {
129                         return 1;
130                 } else {
131                         croak "Wrong content type, expected a scalar";
132                 }
133         } elsif ($which == &Net::Z3950::GRS1::ElementData::Subtree) {
134                 if (ref($content) eq __PACKAGE__) {
135                         return 1;
136                 } else {
137                         croak "Wrong content type, expected a blessed reference";
138                 }
139         } else {
140                 croak "Content type currently not supported";
141         }
142 }
143
144
145 sub CreateElementData {
146         my ($self, $which, $content) = @_;
147         my $ElementData = {};
148
149         $self->CheckTypes($which, $content);
150         $ElementData->{WHICH} = $which;
151         $ElementData->{CONTENT} = $content;
152
153         return $ElementData;
154 }
155
156
157 sub AddElement {
158         my ($self, $type, $value, $which, $content) = @_;
159         my $Elements = $self->GetElementList;
160         my $ElmData = $self->CreateElementData($which, $content);
161         my $TaggedElm = $self->CreateTaggedElement($type, $value, $ElmData);
162
163         push(@$Elements, $TaggedElm);
164 }
165
166
167 sub _Indent {
168         my ($self, $level) = @_;
169         my $space = "";
170
171         foreach (1..$level - 1) {
172                 $space .= "    ";
173         }
174
175         return $space;
176 }
177
178
179 sub _RecordLine {
180         my ($self, $level, $pool, @args) = @_;
181         my $fh = $self->{FH};
182         my $str = sprintf($self->_Indent($level) . shift(@args), @args);
183
184         print $fh $str;
185         if (defined($pool)) {
186                 $$pool .= $str;
187         }
188 }
189
190
191 sub Render {
192         my $self = shift;
193         my %args = (
194                         FORMAT  =>      &Net::Z3950::GRS1::Render::Plain,
195                         FILE    =>      '/dev/null',
196                         LEVEL   =>      0,
197                         HANDLE  =>      undef,
198                         POOL    =>      undef,
199                         @_ );
200         my @Elements = @{$self->GetElementList};
201         my $TaggedElement;
202         my $fh = $args{HANDLE};
203         my $level = ++$args{LEVEL};
204         my $ref = $args{POOL};
205
206         if (!defined($fh) && defined($args{FILE})) {
207                 open(FH, '> ' . $args{FILE}) or croak "Render: Unable to open file '$args{FILE}' for writing: $!";
208                 FH->autoflush(1);
209                 $fh = *FH;
210         }
211         $self->{FH} = defined($fh) ? $fh : $self->{FH};
212         $args{HANDLE} = $fh;
213         foreach $TaggedElement (@Elements) {
214                 my ($type, $value) = $self->GetTypeValue($TaggedElement);
215                 if ($self->GetElementData($TaggedElement)->{WHICH} == &Net::Z3950::GRS1::ElementData::String) {
216                         $self->_RecordLine($level, $ref, "(%s,%s) %s\n", $type, $value, $self->GetElementData($TaggedElement)->{CONTENT});
217                 } elsif ($self->GetElementData($TaggedElement)->{WHICH} == &Net::Z3950::GRS1::ElementData::Subtree) {
218                         $self->_RecordLine($level, $ref, "(%s,%s) {\n", $type, $value);
219                         $self->GetElementData($TaggedElement)->{CONTENT}->Render(%args);
220                         $self->_RecordLine($level, $ref, "}\n");
221                 }
222         }
223         if ($level == 1) {
224                 $self->_RecordLine($level, $ref, "(0,0)\n");
225         }
226 }
227
228
229 package Net::Z3950::GRS1::ElementData;
230
231 ## Define some constants according to the GRS-1 specification
232
233 sub Octets              { 1 }
234 sub Numeric             { 2 }
235 sub Date                { 3 }
236 sub Ext                 { 4 }
237 sub String              { 5 }
238 sub TrueOrFalse         { 6 }
239 sub OID                 { 7 }
240 sub IntUnit             { 8 }
241 sub ElementNotThere     { 9 }
242 sub ElementEmpty        { 10 }
243 sub NoDataRequested     { 11 }
244 sub Diagnostic          { 12 }
245 sub Subtree             { 13 }
246
247
248 package Net::Z3950::GRS1::Render;
249
250 ## Define various types of rendering formats
251
252 sub Plain               { 1 }
253 sub XML                 { 2 }
254 sub Raw                 { 3 }
255
256
257 1;
258
259 __END__
260
261
262 =head1 NAME
263
264 Net::Z3950::Record::GRS1 - Perl package used to encode GRS-1 records.
265
266 =head1 SYNOPSIS
267
268   use Net::Z3950::GRS1;
269
270   my $a_grs1_record = new Net::Z3950::Record::GRS1;
271   my $another_grs1_record = new Net::Z3950::Record::GRS1;
272
273   $a_grs1_record->AddElement($type, $value, $content);
274   $a_grs1_record->Render();
275
276 =head1 DESCRIPTION
277
278 This Perl module helps you to create and manipulate GRS-1 records (generic record syntax).
279 So far, you have only access to three methods:
280
281 =head2 new
282
283 Creates a new GRS-1 object,
284
285   my $grs1 = new Net::Z3950::GRS1;
286
287 =head2 AddElement
288
289 Lets you add entries to a GRS-1 object. The method should be called this way,
290
291   $grs1->AddElement($type, $value, $which, $content);
292
293 where $type should be an integer, and $value is free text. The $which argument should
294 contain one of the constants listed in Appendix A. Finally, $content contains the "thing"
295 that should be stored in this entry. The structure of $content should match the chosen
296 element data type. For
297
298   $which == Net::Z3950::GRS1::ElementData::String;
299
300 $content should be some kind of scalar. If on the other hand,
301
302   $which == Net::Z3950::GRS1::ElementData::Subtree;
303
304 $content should be a GRS1 object.
305
306 =head2 Render
307
308 This method digs through the GRS-1 data structure and renders the record. You call it
309 this way,
310
311   $grs1->Render();
312
313 If you want to access the rendered record through a variable, you can do it like this,
314
315   my $record_as_string;
316   $grs1->Render(POOL => \$record_as_string);
317
318 If you want it stored in a file, Render should be called this way,
319
320   $grs1->Render(FILE => 'record.grs1');
321
322 When no file name is specified, you can choose to stream the rendered record, for instance,
323
324   $grs1->Render(HANDLE => *STDOUT);             ## or
325   $grs1->Render(HANDLE => *STDERR);             ## or
326   $grs1->Render(HANDLE => *MY_HANDLE);
327
328 =head2 Hash2grs
329
330 This method converts a hash into a GRS-1 object. Scalar entries within the hash are converted
331 into GRS-1 string elements. A hash entry can itself be a reference to another hash. In this case,
332 the new referenced hash will be converted into a GRS-1 subtree. The method is called this way,
333
334   $grs1->Hash2grs($href, $mapping);
335
336 where $href is the hash to be converted and $mapping is referenced hash specifying the mapping
337 between keys in $href and (type, value) pairs in the $grs1 object. The $mapping hash could
338 for instance look like this,
339
340   my $mapping = {
341                         title   =>      [2, 1],
342                         author  =>      [1, 1],
343                         issn    =>      [3, 1]
344                 };
345
346 If the $grs1 object contains data prior to the invocation of Hash2grs, the new data represented
347 by the hash is simply added.
348
349
350 =head1 APPENDIX A
351
352 These element data types are specified in the Z39.50 protocol:
353
354   Net::Z3950::GRS1::ElementData::Octets
355   Net::Z3950::GRS1::ElementData::Numeric
356   Net::Z3950::GRS1::ElementData::Date
357   Net::Z3950::GRS1::ElementData::Ext
358   Net::Z3950::GRS1::ElementData::String                 <---
359   Net::Z3950::GRS1::ElementData::TrueOrFalse
360   Net::Z3950::GRS1::ElementData::OID
361   Net::Z3950::GRS1::ElementData::IntUnit
362   Net::Z3950::GRS1::ElementData::ElementNotThere
363   Net::Z3950::GRS1::ElementData::ElementEmpty
364   Net::Z3950::GRS1::ElementData::NoDataRequested
365   Net::Z3950::GRS1::ElementData::Diagnostic
366   Net::Z3950::GRS1::ElementData::Subtree                <---
367
368 Only the '<---' marked types are so far supported in this package.
369
370 =head1 AUTHOR
371
372 Anders S√łnderberg Mortensen <sondberg@indexdata.dk>
373 Index Data ApS, Copenhagen, Denmark.
374 2001/03/09
375
376 =head1 SEE ALSO
377
378 Specification of the GRS-1 standard, for instance in the Z39.50 protocol specification.
379
380 =cut