File Coverage

lib/VM/EC2/Dispatch.pm
Criterion Covered Total %
statement 4 6 66.6
branch n/a
condition n/a
subroutine 2 2 100.0
pod n/a
total 6 8 75.0


line stmt bran cond sub pod time code
1             package VM::EC2::Dispatch;
2              
3 7     7   38 use strict;
  7         10  
  7         289  
4              
5 7     7   2447 use XML::Simple;
  0            
  0            
6             use URI::Escape;
7              
8             =head1 NAME
9              
10             VM::EC2::Dispatch - Create Perl objects from AWS XML requests
11              
12             =head1 SYNOPSIS
13              
14             use VM::EC2;
15              
16             VM::EC2::Dispatch->register('DescribeRegions'=>\&mysub);
17              
18             VM::EC2::Dispatch->replace('DescribeRegions'=>'My::Type');
19            
20             sub mysub {
21             my ($parsed_xml_object,$ec2) = @_;
22             my $payload = $parsed_xml_object->{regionInfo}
23             return My::Type->new($payload,$ec2);
24             }
25              
26             =head1 DESCRIPTION
27              
28             This class handles turning the XML response to AWS requests into perl
29             objects. Only one method is likely to be useful to developers, the
30             replace() class method. This allows you to replace the handlers
31             used to map the response onto objects.
32              
33             =head2 VM::EC2::Dispatch->replace($request_name => \&sub)
34              
35             =head2 VM::EC2::Dispatch->replace($request_name => 'Class::Name')
36              
37             =head2 VM::EC2::Dispatch->replace($request_name => 'method_name,arg1,arg2,...')
38              
39             Before invoking a VM::EC2 request you wish to customize, call the
40             replace() method with two arguments. The first argument is the
41             name of the request you wish to customize, such as
42             "DescribeVolumes". The second argument is either a code reference, a
43             VM::EC2::Dispatch method name and arguments (separated by commas), or
44             a class name.
45              
46             In the case of a code reference as the second argument, the subroutine
47             you provide will be invoked with four arguments consisting of the
48             parsed XML response, the VM::EC2 object, the XML namespace string from
49             the request, and the Amazon-assigned request ID. In practice, only the
50             first two arguments are useful.
51              
52             In the case of a string containing a classname, the class will be
53             loaded if it needs to be, and then its new() method invoked as
54             follows:
55              
56             Your::Class->new($parsed_xml,$ec2,$xmlns,$requestid)
57              
58             Your new() method should return one or more objects. It is suggested
59             that you subclass VM::EC2::Generic and use the inherited new() method
60             to store the parsed XML and EC2 object. See the code for
61             L for a simple template.
62              
63             If the second argument is neither a code reference nor a classname, it
64             will be treated as a VM::EC2::Dispatch method name and its arguments,
65             separated by commas. The method will be invoked as follows:
66              
67             $dispatch->$method_name($raw_xml,$ec2,$arg1,$arg2,$arg3,...)
68              
69             There are two methods currently defined for this purpose, boolean(),
70             and fetch_items(), which handle the preprocessing of several common
71             XML representations of EC2 data. Note that in this form, the RAW XML
72             is passed in, not the parsed data structure.
73              
74             The parsed XML response is generated by the XML::Simple module using
75             these options:
76              
77             $parser = XML::Simple->new(ForceArray => ['item', 'member'],
78             KeyAttr => ['key'],
79             SuppressEmpty => undef);
80             $parsed = $parser->XMLin($raw_xml)
81              
82             In general, this will give you a hash of hashes. Any tag named 'item'
83             or 'member' will be forced to point to an array reference, and any tag
84             named "key" will be flattened as described in the XML::Simple
85             documentation.
86              
87             A simple way to examine the raw parsed XML is to invoke any
88             VM::EC2::Object's as_string method:
89              
90             my ($i) = $ec2->describe_instances;
91             print $i->as_string;
92              
93             This will give you a Data::Dumper representation of the XML after it
94             has been parsed. Look at the calls to VM::EC2::Dispatch->register() in
95             the various VM/EC2/REST/*.pm modules for many examples of how this
96             works.
97              
98             Note that the replace() method was called add_override() in previous
99             versions of this module. add_override() is recognized as an alias for
100             backward compatibility.
101              
102             =head2 VM::EC2::Dispatch->register($request_name1 => \&sub1,$request_name2 => \&sub2,...)
103              
104             Similar to replace() but if the request name is already registered
105             does not overwrite it. You may provide multiple request=>handler pairs.
106              
107             =head1 OBJECT CREATION METHODS
108              
109             The following methods perform simple pre-processing of the parsed XML
110             (a hash of hashes) before passing the modified data structure to the
111             designated object class. They are used as the second argument to
112             VM::EC2::Dispatch->register().
113              
114             =cut
115             ;
116              
117             my $REGISTRATION = {};
118             VM::EC2::Dispatch->register(Error => 'VM::EC2::Error');
119             *add_override = \&replace; # backward compatibility
120              
121             # Not clear that you ever need to instantiate this object as it has
122             # no instance data.
123             sub new {
124             my $class = shift;
125             my $self= bless {},ref $class || $class;
126             return $self;
127             }
128              
129             sub replace {
130             my $self = shift;
131             while (my ($request_name,$object_creator) = splice(@_,0,2)) {
132             $REGISTRATION->{$request_name} = $object_creator;
133             }
134             }
135              
136             sub register {
137             my $self = shift;
138             while (my ($request_name,$object_creator) = splice(@_,0,2)) {
139             $REGISTRATION->{$request_name} ||= $object_creator;
140             }
141             }
142              
143             # new way
144             sub content2objects {
145             my $self = shift;
146             my ($action,$content,$ec2) = @_;
147              
148             my $handler = $REGISTRATION->{$action} || 'VM::EC2::Generic';
149             my ($method,@params) = split /,/,$handler;
150              
151             if (ref $handler eq 'CODE') {
152             my $parsed = $self->new_xml_parser->XMLin($content);
153             my $req_id_tag = $parsed->{requestId} ? 'requestId' : 'RequestId';
154             $handler->($parsed,$ec2,@{$parsed}{'xmlns',$req_id_tag});
155             }
156             elsif ($self->can($method)) {
157             return $self->$method($content,$ec2,@params);
158             }
159             else {
160             load_module($handler);
161             my $parser = $self->new();
162             $parser->parse($content,$ec2,$handler);
163             }
164             }
165              
166             sub parser {
167             my $self = shift;
168             return $self->{xml_parser} ||= $self->new_xml_parser;
169             }
170              
171             sub parse {
172             my $self = shift;
173             my ($content,$ec2,$class) = @_;
174             $self = $self->new unless ref $self;
175             my $parsed = $self->parser->XMLin($content);
176             return $self->create_objects($parsed,$ec2,$class);
177             }
178              
179             sub new_xml_parser {
180             my $self = shift;
181             my $nokey = shift;
182             return XML::Simple->new(ForceArray => ['item', 'member'],
183             KeyAttr => $nokey ? [] : ['key'],
184             SuppressEmpty => undef,
185             );
186             }
187              
188             =head2 $bool = $dispatch->boolean($raw_xml,$ec2,$tag)
189              
190             This is used for XML responses like this:
191              
192            
193             59dbff89-35bd-4eac-99ed-be587EXAMPLE
194             true
195            
196              
197             It looks inside the structure for the tag named $tag ("return" if not
198             provided), and returns a true value if the contents equals "true".
199              
200             Pass it to replace() like this:
201              
202             VM::EC2::Dispatch->replace(DeleteVolume => 'boolean,return';
203              
204             or, since "return" is the default tag:
205              
206             VM::EC2::Dispatch->replace(DeleteVolume => 'boolean';
207              
208             =cut
209              
210             sub boolean {
211             my $self = shift;
212             my ($content,$ec2,$tag) = @_;
213             my $parsed = $self->new_xml_parser()->XMLin($content);
214             $tag ||= 'return';
215             return $parsed->{$tag} eq 'true';
216             }
217              
218             =head2 @list = $dispatch->elb_member_list($raw_xml,$ec2,$tag)
219              
220             This is used for XML responses from the ELB API such as this:
221              
222            
223            
224            
225             us-west-2a
226             us-west-2b
227            
228            
229            
230             02eadcfc-fc38-11e1-a1bf-9de31EXAMPLE
231            
232            
233              
234             It looks inside the Result structure for the tag named $tag and returns the
235             list wrapped in member elements. In this case the tag is 'AvailabilityZones'
236             and the return value would be:
237             ( 'us-west-2a', 'us-west-2b' )
238              
239             If $embedded_tag is passed, then it is used for XML responses such as this,
240             where the member list has an embedded tag:
241              
242            
243            
244            
245            
246             i-12345678
247            
248            
249             i-90abcdef
250            
251            
252            
253            
254             f4f12596-fc3b-11e1-be5a-f71ecEXAMPLE
255            
256            
257              
258             It looks inside the Result structure for the tag named $tag and returns the
259             list wrapped in a member element plus the embedded tag. In this case the
260             tag is 'Instances', the embedded tag is 'InstanceId' and the return value would
261             be: ( 'i-12345678', 'i-90abcdef' )
262              
263             =cut
264              
265             sub elb_member_list {
266             my $self = shift;
267             my ($content,$ec2,$tag,$embedded_tag) = @_;
268             my $parsed = $self->new_xml_parser()->XMLin($content);
269             my ($result_key) = grep /Result$/,keys %$parsed;
270             return $embedded_tag ? map { $_->{$embedded_tag} } @{$parsed->{$result_key}{$tag}{member}} :
271             @{$parsed->{$result_key}{$tag}{member}};
272             }
273              
274             # identical to fetch_one, except looks inside the (APICallName)Result tag that
275             # ELB and RDS API calls return
276             sub fetch_one_result {
277             my $self = shift;
278             my ($content,$ec2,$tag,$class,$nokey) = @_;
279             load_module($class);
280             my $parser = $self->new_xml_parser($nokey);
281             my $parsed = $parser->XMLin($content);
282             my ($result_key) = grep /Result$/,keys %$parsed;
283             my $obj = $parsed->{$result_key}{$tag} or return;
284             return $class->new($obj,$ec2,@{$parsed}{'xmlns','RequestId'});
285             }
286              
287             sub fetch_one {
288             my $self = shift;
289             my ($content,$ec2,$tag,$class,$nokey) = @_;
290             load_module($class);
291             my $parser = $self->new_xml_parser($nokey);
292             my $parsed = $parser->XMLin($content);
293             my $obj = $parsed->{$tag} or return;
294             return $class->new($obj,$ec2,@{$parsed}{'xmlns','requestId'});
295             }
296              
297             =head2 @objects = $dispatch->fetch_items($raw_xml,$ec2,$container_tag,$object_class,$nokey)
298              
299             This is used for XML responses like this:
300              
301            
302             59dbff89-35bd-4eac-99ed-be587EXAMPLE
303            
304            
305             gsg-keypair
306            
307             1f:51:ae:28:bf:89:e9:d8:1f:25:5d:37:2d:7d:b8:ca:9f:f5:f1:6f
308            
309            
310            
311             default-keypair
312            
313             0a:93:bb:e8:c2:89:e9:d8:1f:42:5d:37:1d:8d:b8:0a:88:f1:f1:1a
314            
315            
316            
317            
318              
319             It looks inside the structure for the tag named $container_tag, pulls
320             out the items that are stored under and then passes the parsed
321             contents to $object_class->new(). The optional $nokey argument is used
322             to suppress XML::Simple's default flattening behavior turning tags
323             named "key" into hash keys.
324              
325             Pass it to replace() like this:
326              
327             VM::EC2::Dispatch->replace(DescribeVolumes => 'fetch_items,volumeSet,VM::EC2::Volume')
328              
329             =cut
330              
331             sub fetch_items {
332             my $self = shift;
333             my ($content,$ec2,$tag,$class,$nokey) = @_;
334             load_module($class);
335             my $parser = $self->new_xml_parser($nokey);
336             my $parsed = $parser->XMLin($content);
337             my $list = $parsed->{$tag}{item} or return;
338             return map {$class->new($_,$ec2,@{$parsed}{'xmlns','requestId'})} @$list;
339             }
340              
341             =head2 @objects = $dispatch->fetch_members($raw_xml,$ec2,$container_tag,$object_class,$nokey)
342              
343             Used for XML responses from ELB API calls which contain a key that is the name
344             of the API call with 'Result' appended. All these XML responses contain
345             'member' as the item delimiter instead of 'item'
346              
347             =cut
348              
349             sub fetch_members {
350             my $self = shift;
351             my ($content,$ec2,$tag,$class,$nokey) = @_;
352             load_module($class);
353             my $parser = $self->new_xml_parser($nokey);
354             my $parsed = $parser->XMLin($content);
355             my ($result_key) = grep /Result$/,keys %$parsed;
356             my $list = $parsed->{$result_key}{$tag}{member} or return;
357             return map {$class->new($_,$ec2,@{$parsed}{'xmlns','RequestId'})} @$list;
358             }
359              
360             =head2 @objects = $dispatch->fetch_rds_objects($raw_xml,$ec2,$container_tag,$object_class,$nokey)
361              
362             Used for XML responses from RDS API calls which contain a key that is the name
363             of the API call with 'Result' appended. In addition, the structure is a list
364             of objects wrapped in a plural version of the object's name.
365              
366             =cut
367              
368             sub fetch_rds_objects {
369             my $self = shift;
370             my ($content,$ec2,$tag,$class,$nokey) = @_;
371             load_module($class);
372             my $parser = $self->new_xml_parser($nokey);
373             my $parsed = $parser->XMLin($content);
374             my ($result_key) = grep /Result$/,keys %$parsed;
375             # xml tags in api are not entirely consistent
376             my @endings = qw/s sList List/;
377             my $list_tag;
378             foreach (@endings) {
379             $list_tag = $tag . $_;
380             last if exists $parsed->{$result_key}{$list_tag};
381             }
382             my $list = $parsed->{$result_key}{$list_tag}{$tag} or return;
383             return ref $list eq 'HASH' ?
384             ($class->new($list,$ec2,@{$parsed}{'xmlns','RequestId'})) :
385             map {$class->new($_,$ec2,@{$parsed}{'xmlns','RequestId'})} @$list;
386             }
387              
388             =head2 @objects = $dispatch->fetch_items_iterator($raw_xml,$ec2,$container_tag,$object_class,$token_name)
389              
390             This is used for requests that have a -max_results argument. In this
391             case, the response will have a nextToken field, which can be used to
392             fetch the "next page" of results.
393              
394             The $token_name is some unique identifying token. It will be turned
395             into two temporary EC2 instance variables, one named
396             "${token_name}_token", which contains the nextToken value, and the
397             other "${token_name}_stop", which flags the caller that no more
398             results will be forthcoming.
399              
400             This must all be coordinated with the request subroutine. See how
401             describe_instance_status() and describe_spot_price_history() do it.
402              
403             =cut
404              
405             sub fetch_items_iterator {
406             my $self = shift;
407             my ($content,$ec2,$tag,$class,$base_name) = @_;
408             my $token = "${base_name}_token";
409             my $stop = "${base_name}_stop";
410              
411             load_module($class);
412             my $parser = $self->new_xml_parser();
413             my $parsed = $parser->XMLin($content);
414             my $list = $parsed->{$tag}{item} or return;
415              
416             if ($ec2->{$token} && !$parsed->{nextToken}) {
417             delete $ec2->{$token};
418             $ec2->{$stop}++;
419             } else {
420             $ec2->{$token} = $parsed->{nextToken};
421             }
422             return map {$class->new($_,$ec2,@{$parsed}{'xmlns','requestId'})} @$list;
423             }
424              
425             sub create_objects {
426             my $self = shift;
427             my ($parsed,$ec2,$class) = @_;
428             return $class->new($parsed,$ec2,@{$parsed}{'xmlns','requestId'});
429             }
430              
431             sub create_error_object {
432             my $self = shift;
433             my ($content,$ec2,$API_call) = @_;
434             my $class = $REGISTRATION->{Error};
435             eval "require $class; 1" || die $@ unless $class->can('new');
436             my $parsed = $self->new_xml_parser->XMLin($content);
437             if (defined $API_call) {
438             $parsed->{Errors}{Error}{Message} =~ s/\.$//;
439             $parsed->{Errors}{Error}{Message} .= ", at API call '$API_call'";
440             }
441             return $class->new($parsed->{Errors}{Error},$ec2,@{$parsed}{'xmlns','RequestID'});
442             }
443              
444             # alternate method used for ELB, RDS calls
445             sub create_alt_error_object {
446             my $self = shift;
447             my ($content,$ec2) = @_;
448             my $class = 'VM::EC2::Error';
449             eval "require $class; 1" || die $@ unless $class->can('new');
450             my $parsed = $self->new_xml_parser->XMLin($content);
451             return $class->new($parsed->{Error},$ec2,@{$parsed}{'xmlns','RequestId'});
452             }
453              
454             # not a method!
455             sub load_module {
456             my $class = shift;
457             eval "require $class; 1" || die $@ unless $class->can('new');
458             }
459              
460             =head1 EXAMPLE OF USING OVERRIDE TO SUBCLASS VM::EC2::Volume
461              
462             The author decided that a volume object should not be able to delete
463             itself; you disagree with that decision. Let's subclass
464             VM::EC2::Volume to add a delete() method.
465              
466             First subclass the VM::EC2::Volume class:
467              
468             package MyVolume;
469             use base 'VM::EC2::Volume';
470              
471             sub delete {
472             my $self = shift;
473             $self->ec2->delete_volume($self);
474             }
475              
476             Now subclass VM::EC2 to add the appropriate overrides to the new() method:
477              
478             package MyEC2;
479             use base 'VM::EC2';
480              
481             sub new {
482             my $class = shift;
483             VM::EC2::Dispatch->replace(CreateVolume =>'MyVolume');
484             VM::EC2::Dispatch->replace(DescribeVolumes=>'fetch_items,volumeSet,MyVolume');
485             return $class->SUPER::new(@_);
486             }
487              
488             Now we can test it out:
489              
490             use MyEC2;
491             # find all volumes that are "available" and not in-use
492             my @vol = $ec2->describe_volumes({status=>'available'});
493             for my $vol (@vol) {
494             $vol->delete && print "$vol deleted\n"
495             }
496            
497             =head1 SEE ALSO
498              
499             L
500             L
501             L
502             L
503             L
504             L
505             L
506             L
507             L
508             L
509             L
510             L
511             L
512             L
513             L
514             L
515             L
516             L
517             L
518             L
519             L
520             L
521             L
522              
523             =head1 AUTHOR
524              
525             Lincoln Stein Elincoln.stein@gmail.comE.
526              
527             Copyright (c) 2011 Ontario Institute for Cancer Research
528              
529             This package and its accompanying libraries is free software; you can
530             redistribute it and/or modify it under the terms of the GPL (either
531             version 1, or at your option, any later version) or the Artistic
532             License 2.0. Refer to LICENSE for the full license text. In addition,
533             please see DISCLAIMER.txt for disclaimers of warranty.
534              
535             =cut
536              
537             1;
538