1## This file is part of simpleserver
2## Copyright (C) 2000-2015 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
27package Net::Z3950::GRS1;
28
29use strict;
30use IO::Handle;
31use Carp;
32
33sub 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
52sub 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
88sub GetElementList {
89	my $self = shift;
90
91	return $self->{ELEMENTS};
92}
93
94
95sub 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
110sub GetTypeValue {
111	my ($self, $TaggedElement) = @_;
112
113	return ($TaggedElement->{TYPE}, $TaggedElement->{VALUE});
114}
115
116
117sub GetElementData {
118	my ($self, $TaggedElement) = @_;
119
120	return $TaggedElement->{ELEMENTDATA};
121}
122
123
124sub 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
145sub 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
157sub 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
167sub _Indent {
168	my ($self, $level) = @_;
169	my $space = "";
170
171	foreach (1..$level - 1) {
172		$space .= "    ";
173	}
174
175	return $space;
176}
177
178
179sub _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
191sub 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
229package Net::Z3950::GRS1::ElementData;
230
231## Define some constants according to the GRS-1 specification
232
233sub Octets		{ 1 }
234sub Numeric		{ 2 }
235sub Date		{ 3 }
236sub Ext			{ 4 }
237sub String		{ 5 }
238sub TrueOrFalse		{ 6 }
239sub OID			{ 7 }
240sub IntUnit		{ 8 }
241sub ElementNotThere	{ 9 }
242sub ElementEmpty	{ 10 }
243sub NoDataRequested	{ 11 }
244sub Diagnostic		{ 12 }
245sub Subtree		{ 13 }
246
247
248package Net::Z3950::GRS1::Render;
249
250## Define various types of rendering formats
251
252sub Plain		{ 1 }
253sub XML			{ 2 }
254sub Raw			{ 3 }
255
256
2571;
258
259__END__
260
261
262=head1 NAME
263
264Net::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
278This Perl module helps you to create and manipulate GRS-1 records (generic record syntax).
279So far, you have only access to three methods:
280
281=head2 new
282
283Creates a new GRS-1 object,
284
285  my $grs1 = new Net::Z3950::GRS1;
286
287=head2 AddElement
288
289Lets you add entries to a GRS-1 object. The method should be called this way,
290
291  $grs1->AddElement($type, $value, $which, $content);
292
293where $type should be an integer, and $value is free text. The $which argument should
294contain one of the constants listed in Appendix A. Finally, $content contains the "thing"
295that should be stored in this entry. The structure of $content should match the chosen
296element 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
308This method digs through the GRS-1 data structure and renders the record. You call it
309this way,
310
311  $grs1->Render();
312
313If 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
318If you want it stored in a file, Render should be called this way,
319
320  $grs1->Render(FILE => 'record.grs1');
321
322When 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
330This method converts a hash into a GRS-1 object. Scalar entries within the hash are converted
331into GRS-1 string elements. A hash entry can itself be a reference to another hash. In this case,
332the new referenced hash will be converted into a GRS-1 subtree. The method is called this way,
333
334  $grs1->Hash2grs($href, $mapping);
335
336where $href is the hash to be converted and $mapping is referenced hash specifying the mapping
337between keys in $href and (type, value) pairs in the $grs1 object. The $mapping hash could
338for instance look like this,
339
340  my $mapping =	{
341			title	=>	[2, 1],
342			author	=>	[1, 1],
343			issn	=>	[3, 1]
344		};
345
346If the $grs1 object contains data prior to the invocation of Hash2grs, the new data represented
347by the hash is simply added.
348
349
350=head1 APPENDIX A
351
352These 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
368Only the '<---' marked types are so far supported in this package.
369
370=head1 AUTHOR
371
372Anders S�nderberg Mortensen <sondberg@indexdata.dk>
373Index Data ApS, Copenhagen, Denmark.
3742001/03/09
375
376=head1 SEE ALSO
377
378Specification of the GRS-1 standard, for instance in the Z39.50 protocol specification.
379
380=cut
381