/[cvs]/joko/Scripts/psh/lib/RPC/XML/Parser.pm
ViewVC logotype

Contents of /joko/Scripts/psh/lib/RPC/XML/Parser.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (show annotations) (vendor branch)
Fri Jun 14 21:22:13 2002 UTC (22 years, 3 months ago) by cvsjoko
Branch: nfo, MAIN
CVS Tags: r001, HEAD
Changes since 1.1: +0 -0 lines
first import

1 ###############################################################################
2 #
3 # This file copyright (c) 2001 by Randy J. Ray, all rights reserved
4 #
5 # Copying and distribution are permitted under the terms of the Artistic
6 # License as distributed with Perl versions 5.005 and later. See
7 # http://language.perl.com/misc/Artistic.html
8 #
9 ###############################################################################
10 #
11 # $Id: Parser.pm,v 1.4 2002/05/22 09:44:49 rjray Exp $
12 #
13 # Description: This is the RPC::XML::Parser class, a container for the
14 # XML::Parser class. It was moved here from RPC::XML in
15 # order to reduce the weight of that module.
16 #
17 # Functions: new
18 # parse
19 # message_init
20 # tag_start
21 # error
22 # stack_error
23 # tag_end
24 # char_data
25 #
26 # Libraries: RPC::XML
27 # XML::Parser
28 #
29 # Global Consts: Uses $RPC::XML::ERROR
30 #
31 # Environment: None.
32 #
33 ###############################################################################
34
35 package RPC::XML::Parser;
36
37 use 5.005;
38 use strict;
39 use vars qw($VERSION @ISA);
40 use subs qw(error stack_error new message_init message_end tag_start tag_end
41 char_data parse);
42
43 # These constants are only used by the internal stack machine
44 use constant PARSE_ERROR => 0;
45 use constant METHOD => 1;
46 use constant METHODSET => 2;
47 use constant RESPONSE => 3;
48 use constant RESPONSESET => 4;
49 use constant STRUCT => 5;
50 use constant ARRAY => 6;
51 use constant DATATYPE => 7;
52 use constant ATTR_SET => 8;
53 use constant METHODNAME => 9;
54 use constant VALUEMARKER => 10;
55 use constant PARAMSTART => 11;
56 use constant PARAM => 12;
57 use constant STRUCTMEM => 13;
58 use constant STRUCTNAME => 14;
59 use constant DATAOBJECT => 15;
60 use constant PARAMLIST => 16;
61 use constant NAMEVAL => 17;
62 use constant MEMBERENT => 18;
63 use constant METHODENT => 19;
64 use constant RESPONSEENT => 20;
65 use constant FAULTENT => 21;
66 use constant FAULTSTART => 22;
67
68 # This is to identify valid types
69 use constant VALIDTYPES => { map { $_, 1 } qw(int i4 string double reference
70 boolean dateTime.iso8601
71 base64) };
72 # This maps XML tags to stack-machine tokens
73 use constant TAG2TOKEN => { methodCall => METHOD,
74 methodResponse => RESPONSE,
75 methodName => METHODNAME,
76 params => PARAMSTART,
77 param => PARAM,
78 value => VALUEMARKER,
79 fault => FAULTSTART,
80 array => ARRAY,
81 struct => STRUCT,
82 member => STRUCTMEM,
83 name => STRUCTNAME };
84
85 use XML::Parser;
86
87 require RPC::XML;
88
89 $VERSION = do { my @r=(q$Revision: 1.4 $=~/\d+/g); sprintf "%d."."%02d"x$#r,@r };
90
91 1;
92
93 ###############################################################################
94 #
95 # Sub Name: new
96 #
97 # Description: Constructor. Save any important attributes, leave the
98 # heavy lifting for the parse() routine and XML::Parser.
99 #
100 # Arguments: NAME IN/OUT TYPE DESCRIPTION
101 # $class in scalar Class we're initializing
102 # %attr in hash Any extras the caller wants
103 #
104 # Globals: $RPC::XML::ERROR
105 #
106 # Environment: None.
107 #
108 # Returns: Success: object ref
109 # Failure: undef
110 #
111 ###############################################################################
112 sub new
113 {
114 my $class = shift;
115 my %attrs = @_;
116
117 my $self = {};
118 if (keys %attrs)
119 {
120 for (keys %attrs) { $self->{$_} = $attrs{$_} }
121 }
122
123 bless $self, $class;
124 }
125
126 ###############################################################################
127 #
128 # Sub Name: parse
129 #
130 # Description: Parse the requested string or stream. This behaves mostly
131 # like parse() in the XML::Parser namespace, but does some
132 # extra, as well.
133 #
134 # Arguments: NAME IN/OUT TYPE DESCRIPTION
135 # $self in ref Object of this class
136 # $stream in scalar Either the string to parse or
137 # an open filehandle of sorts
138 #
139 # Globals: None.
140 #
141 # Environment: None.
142 #
143 # Returns: Success: ref to request or response object
144 # Failure: error string
145 #
146 ###############################################################################
147 sub parse
148 {
149 my $self = shift;
150 my $stream = shift;
151
152 my $parser = XML::Parser->new(Namespaces => 0, ParseParamEnt => 0,
153 Handlers =>
154 {
155 Init => sub { message_init $self, @_ },
156 Start => sub { tag_start $self, @_ },
157 End => sub { tag_end $self, @_ },
158 Char => sub { char_data $self, @_ },
159 });
160
161 eval { $parser->parse($stream) };
162 return $@ if $@;
163 # Look at the top-most marker, it'll need to be one of the end cases
164 my $marker = pop(@{$self->{stack}});
165 # There should be only on item on the stack after it
166 my $retval = pop(@{$self->{stack}});
167 # If the top-most marker isn't the error marker, check the stack
168 $retval = 'RPC::XML Error: Extra data on parse stack at document end'
169 if ($marker != PARSE_ERROR and (@{$self->{stack}}));
170
171 $retval;
172 }
173
174 # This is called when a new document is about to start parsing
175 sub message_init
176 {
177 my $robj = shift;
178 my $self = shift;
179
180 $robj->{stack} = [];
181 $self;
182 }
183
184 # This gets called each time an opening tag is parsed
185 sub tag_start
186 {
187 my $robj = shift;
188 my $self = shift;
189 my $elem = shift;
190 my %attr = @_;
191
192 $robj->{cdata} = '';
193 return if ($elem eq 'data');
194 if (TAG2TOKEN->{$elem})
195 {
196 push(@{$robj->{stack}}, TAG2TOKEN->{$elem});
197 }
198 elsif (VALIDTYPES->{$elem})
199 {
200 # All datatypes are represented on the stack by this generic token
201 push(@{$robj->{stack}}, DATATYPE);
202 }
203 else
204 {
205 push(@{$robj->{stack}},
206 "Unknown tag encountered: $elem", PARSE_ERROR);
207 $self->finish;
208 }
209 }
210
211 # Very simple error-text generator, just to eliminate heavy reduncancy in the
212 # next sub:
213 sub error
214 {
215 my $robj = shift;
216 my $self = shift;
217 my $mesg = shift;
218 my $elem = shift || '';
219
220 my $fmt = $elem ?
221 '%s at document line %d, column %d (byte %d, closing tag %s)' :
222 '%s at document line %d, column %d (byte %d)';
223
224 push(@{$robj->{stack}},
225 sprintf($fmt, $mesg, $self->current_line, $self->current_column,
226 $self->current_byte, $elem),
227 PARSE_ERROR);
228 $self->finish;
229 }
230
231 # A shorter-cut for stack integrity errors
232 sub stack_error
233 {
234 my $robj = shift;
235 my $self = shift;
236 my $elem = shift;
237
238 error($robj, $self, 'Stack corruption detected', $elem);
239 }
240
241 # This is a hairy subroutine-- what to do at the end-tag. The actions range
242 # from simply new-ing a datatype all the way to building the final object.
243 sub tag_end
244 {
245 my $robj = shift;
246 my $self = shift;
247 my $elem = shift;
248
249 my ($op, $attr, $obj, $class, $list, $name, $err);
250
251 return if ($elem eq 'data');
252 # This should always be one of the stack machine ops defined above
253 $op = pop(@{$robj->{stack}});
254
255 # Decide what to do from here
256 if (VALIDTYPES->{$elem})
257 {
258 # This is the closing tag of one of the data-types.
259 ($class = lc $elem) =~ s/\./_/;
260 # Some minimal data-integrity checking
261 if ($class eq 'int' or $class eq 'i4')
262 {
263 return error($robj, $self, 'Bad integer data read')
264 unless ($robj->{cdata} =~ /^[-+]?\d+$/);
265 }
266 elsif ($class eq 'double')
267 {
268 return error($robj, $self, 'Bad floating-point data read')
269 unless ($robj->{cdata} =~
270 # Taken from perldata(1)
271 /^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/);
272 }
273
274 $class = "RPC::XML::$class";
275 $obj = $class->new($robj->{cdata});
276 return error($robj, $self, 'Error instantiating data object: ' .
277 $RPC::XML::ERROR)
278 unless ($obj);
279 push(@{$robj->{stack}}, $obj, DATAOBJECT);
280 }
281 elsif ($elem eq 'value')
282 {
283 # For <value></value>, there should already be a dataobject, or else
284 # the marker token in which case the CDATA is used as a string value.
285 if ($op == DATAOBJECT)
286 {
287 ($op, $obj) = splice(@{$robj->{stack}}, -2);
288 return stack_error($robj, $self, $elem)
289 unless ($op == VALUEMARKER);
290 }
291 elsif ($op == VALUEMARKER)
292 {
293 $obj = RPC::XML::string->new($robj->{cdata});
294 }
295 else
296 {
297 return error($robj, $self,
298 'No datatype found within <value> container');
299 }
300
301 push(@{$robj->{stack}}, $obj, DATAOBJECT);
302 }
303 elsif ($elem eq 'param')
304 {
305 # Almost like above, since this is really a NOP anyway
306 return error($robj, $self, 'No <value> found within <param> container')
307 unless ($op == DATAOBJECT);
308 ($op, $obj) = splice(@{$robj->{stack}}, -2);
309 return stack_error($robj, $self, $elem) unless ($op == PARAM);
310 push(@{$robj->{stack}}, $obj, DATAOBJECT);
311 }
312 elsif ($elem eq 'params')
313 {
314 # At this point, there should be zero or more DATAOBJECT tokens on the
315 # stack, each with a data object right below it.
316 $list = [];
317 return stack_error($robj, $self, $elem)
318 unless ($op == DATAOBJECT or $op == PARAMSTART);
319 while ($op == DATAOBJECT)
320 {
321 unshift(@$list, pop(@{$robj->{stack}}));
322 $op = pop(@{$robj->{stack}});
323 }
324 # Now that we see something ! DATAOBJECT, it needs to be PARAMSTART
325 return stack_error($robj, $self, $elem) unless ($op == PARAMSTART);
326 push(@{$robj->{stack}}, $list, PARAMLIST);
327 }
328 elsif ($elem eq 'fault')
329 {
330 # If we're finishing up a fault definition, there needs to be a struct
331 # on the stack.
332 return stack_error($robj, $self, $elem) unless ($op == DATAOBJECT);
333 ($op, $obj) = splice(@{$robj->{stack}}, -2);
334 return error($robj, $self,
335 'Only a <struct> value may be within a <fault>')
336 unless ($obj->isa('RPC::XML::struct'));
337
338 $obj = RPC::XML::fault->new($obj);
339 return error($robj, $self, 'Unable to instantiate fault object: ' .
340 $RPC::XML::ERROR)
341 unless $obj;
342 push(@{$robj->{stack}}, $obj, FAULTENT);
343 }
344 elsif ($elem eq 'member')
345 {
346 # We need to see a DATAOBJECT followed by a STRUCTNAME
347 return stack_error($robj, $self, $elem) unless ($op == DATAOBJECT);
348 ($op, $obj) = splice(@{$robj->{stack}}, -2);
349 return stack_error($robj, $self, $elem) unless ($op == STRUCTNAME);
350 # Get the name off the stack to clear the way for the STRUCTMEM marker
351 # under it
352 ($op, $name) = splice(@{$robj->{stack}}, -2);
353 # Push the name back on, with the value and the new marker (STRUCTMEM)
354 push(@{$robj->{stack}}, $name, $obj, STRUCTMEM);
355 }
356 elsif ($elem eq 'name')
357 {
358 # Fairly simple: just push the current content of CDATA on w/ a marker
359 push(@{$robj->{stack}}, $robj->{cdata}, STRUCTNAME);
360 }
361 elsif ($elem eq 'struct')
362 {
363 # Create the hash table in-place, then pass the ref to the constructor
364 $list = {};
365 # First off the stack needs to be STRUCTMEM or STRUCT
366 return stack_error($robj, $self, $elem)
367 unless ($op == STRUCTMEM or $op == STRUCT);
368 while ($op == STRUCTMEM)
369 {
370 # Next on stack (in list-order): name, value
371 ($name, $obj) = splice(@{$robj->{stack}}, -2);
372 $list->{$name} = $obj;
373 $op = pop(@{$robj->{stack}});
374 }
375 # Now that we see something ! STRUCTMEM, it needs to be STRUCT
376 return stack_error($robj, $self, $elem) unless ($op == STRUCT);
377 $obj = RPC::XML::struct->new($list);
378 return error($robj, $self,
379 'Error creating a RPC::XML::struct object: ' .
380 $RPC::XML::ERROR)
381 unless $obj;
382 push(@{$robj->{stack}}, $obj, DATAOBJECT);
383 }
384 elsif ($elem eq 'array')
385 {
386 # This is similar in most ways to struct creation, save for the lack
387 # of naming for the elements.
388 # Create the list in-place, then pass the ref to the constructor
389 $list = [];
390 # Only DATAOBJECT or ARRAY should be visible
391 return stack_error($robj, $self, $elem)
392 unless ($op == DATAOBJECT or $op == ARRAY);
393 while ($op == DATAOBJECT)
394 {
395 unshift(@$list, pop(@{$robj->{stack}}));
396 $op = pop(@{$robj->{stack}});
397 }
398 # Now that we see something ! DATAOBJECT, it needs to be ARRAY
399 return stack_error($robj, $self, $elem) unless ($op == ARRAY);
400 $obj = RPC::XML::array->new($list);
401 return error($robj, $self,
402 'Error creating a RPC::XML::array object: ' .
403 $RPC::XML::ERROR)
404 unless $obj;
405 push(@{$robj->{stack}}, $obj, DATAOBJECT);
406 }
407 elsif ($elem eq 'methodName')
408 {
409 return error($robj, $self,
410 "<$elem> tag must immediately follow a <methodCall> tag")
411 unless ($robj->{stack}->[$#{$robj->{stack}}] == METHOD);
412 push(@{$robj->{stack}}, $robj->{cdata}, NAMEVAL);
413 }
414 elsif ($elem eq 'methodCall')
415 {
416 # A methodCall closing should have on the stack an optional PARAMLIST
417 # marker, a NAMEVAL marker, then the METHOD token from the
418 # opening tag. An ATTR_SET may follow the METHOD token.
419 if ($op == PARAMLIST)
420 {
421 ($op, $list) = splice(@{$robj->{stack}}, -2);
422 }
423 else
424 {
425 $list = [];
426 }
427 if ($op == NAMEVAL)
428 {
429 ($op, $name) = splice(@{$robj->{stack}}, -2);
430 }
431 return error($robj, $self,
432 "No methodName tag detected during methodCall parsing")
433 unless $name;
434 return stack_error($robj, $self, $elem) unless ($op == METHOD);
435 # Create the request object and push it on the stack
436 $obj = RPC::XML::request->new($name, @$list);
437 return error($robj, $self,
438 "Error creating request object: $RPC::XML::ERROR")
439 unless $obj;
440 push(@{$robj->{stack}}, $obj, METHODENT);
441 }
442 elsif ($elem eq 'methodResponse')
443 {
444 # A methodResponse closing should have on the stack only the
445 # DATAOBJECT marker, then the RESPONSE token from the opening tag.
446 if ($op == PARAMLIST)
447 {
448 # To my knowledge, the XML-RPC spec limits the params list for
449 # a response to exactly one object. Extract it from the listref
450 # and put it back.
451 $list = pop(@{$robj->{stack}});
452 return error($robj, $self,
453 "Params list for <$elem> tag invalid")
454 unless (@$list == 1);
455 $obj = $list->[0];
456 return error($robj, $self,
457 "Returned value on stack not a type reference")
458 unless (ref $obj and $obj->isa('RPC::XML::datatype'));
459 push(@{$robj->{stack}}, $obj);
460 }
461 elsif (! ($op == DATAOBJECT or $op == FAULTENT))
462 {
463 return error($robj, $self,
464 "No parameter was declared for the <$elem> tag");
465 }
466 ($op, $list) = splice(@{$robj->{stack}}, -2);
467 return stack_error($robj, $self, $elem) unless ($op == RESPONSE);
468 # Create the response object and push it on the stack
469 $obj = RPC::XML::response->new($list);
470 return error($robj, $self,
471 "Error creating response object: $RPC::XML::ERROR")
472 unless $obj;
473 push(@{$robj->{stack}}, $obj, RESPONSEENT);
474 }
475 }
476
477 # This just spools the character data until a closing tag makes use of it
478 sub char_data
479 {
480 my $robj = shift;
481 my $self = shift;
482 my $data = shift;
483
484 $robj->{cdata} .= $data;
485 }
486
487 __END__
488
489 =head1 NAME
490
491 RPC::XML::Parser - A container class for XML::Parser
492
493 =head1 SYNOPSIS
494
495 use RPC::XML::Parser;
496 ...
497 $P = RPC::XML::Parser->new();
498 $P->parse($message);
499
500 =head1 DESCRIPTION
501
502 The B<RPC::XML::Parser> class encapsulates the parsing process, for turning a
503 string or an input stream into a B<RPC::XML::request> or B<RPC::XML::response>
504 object. The B<XML::Parser> class is used internally, with a new instance
505 created for each call to C<parse> (detailed below). This allows the
506 B<RPC::XML::Parser> object to be reusable, even though the B<XML::Parser>
507 objects are not. The methods are:
508
509 =over 4
510
511 =item new
512
513 Create a new instance of the class. Any extra data passed to the constructor
514 is taken as key/value pairs (B<not> a hash reference) and attached to the
515 object.
516
517 =item parse { STRING | STREAM }
518
519 Parse the XML document specified in either a string or a stream. The stream
520 may be any file descriptor, derivative of B<IO::Handle>, etc. The return
521 value is either an object reference (to one of B<RPC::XML::request> or
522 B<RPC::XML::response>) or an error string. Any non-reference return value
523 should be treated as an error condition.
524
525 =back
526
527 =head1 DIAGNOSTICS
528
529 The constructor returns C<undef> upon failure, with the error message available
530 in the global variable B<C<$RPC::XML::ERROR>>.
531
532 =head1 CAVEATS
533
534 This began as a reference implementation in which clarity of process and
535 readability of the code took precedence over general efficiency. It is now
536 being maintained as production code, but may still have parts that could be
537 written more efficiently.
538
539 =head1 CREDITS
540
541 The B<XML-RPC> standard is Copyright (c) 1998-2001, UserLand Software, Inc.
542 See <http://www.xmlrpc.com> for more information about the B<XML-RPC>
543 specification.
544
545 =head1 LICENSE
546
547 This module is licensed under the terms of the Artistic License that covers
548 Perl. See <http://language.perl.com/misc/Artistic.html> for the
549 license itself.
550
551 =head1 SEE ALSO
552
553 L<RPC::XML>, L<RPC::XML::Client>, L<RPC::XML::Server>, L<XML::Parser>
554
555 =head1 AUTHOR
556
557 Randy J. Ray <rjray@blackperl.com>
558
559 =cut

MailToCvsAdmin">MailToCvsAdmin
ViewVC Help
Powered by ViewVC 1.1.26 RSS 2.0 feed