File Coverage

blib/lib/RPC/XML/ParserFactory.pm
Criterion Covered Total %
statement 27 38 71.0
branch 4 12 33.3
condition 2 3 66.6
subroutine 7 7 100.0
pod n/a
total 40 60 66.6


line stmt bran cond sub pod time code
1             ###############################################################################
2             #
3             # This file copyright (c) 2001-2011 Randy J. Ray, all rights reserved
4             #
5             # Copying and distribution are permitted under the terms of the Artistic
6             # License 2.0 (http://www.opensource.org/licenses/artistic-license-2.0.php) or
7             # the GNU LGPL (http://www.opensource.org/licenses/lgpl-2.1.php).
8             #
9             ###############################################################################
10             #
11             # Description: This is the RPC::XML::ParserFactory class, a factory for
12             # classes that derive from the RPC::XML::Parser class.
13             #
14             # Functions: import
15             # new
16             # register
17             #
18             # Libraries: RPC::XML::Parser::XMLParser \
19             # RPC::XML::Parser::XMLLibXML > One (or more) of these
20             # RPC::XML::Parser::XMLSAX /
21             #
22             # Global Consts: $VERSION
23             #
24             # Environment: None.
25             #
26             ###############################################################################
27              
28             package RPC::XML::ParserFactory;
29              
30 8     8   1543 use 5.008008;
  8         28  
  8         536  
31 8     8   47 use strict;
  8         16  
  8         278  
32 8     8   47 use warnings;
  8         16  
  8         326  
33 8     8   41 use vars qw($VERSION %AVAILABLE $PARSER_CLASS);
  8         14  
  8         661  
34 8     8   42 use subs qw(import new register);
  8         12  
  8         73  
35              
36             # Because this is a factory class, there are some eval's that violate this
37             # critic policy, but can't be worked around:
38             ## no critic (RequireCheckingReturnValueOfEval)
39              
40             $VERSION = '1.03';
41             $VERSION = eval $VERSION; ## no critic (ProhibitStringyEval)
42              
43             # These are the known parsers supported, not including any that are specified
44             # by the user at import-time.
45             $PARSER_CLASS = 'XML::Parser';
46             %AVAILABLE = (
47             'XML::Parser' => 'RPC::XML::Parser::XMLParser',
48             'XML::LibXML' => 'RPC::XML::Parser::XMLLibXML',
49             );
50              
51             # "Normalize" the key-names to allow some simplicity (and sugar):
52             for (keys %AVAILABLE)
53             {
54             my $key = lc $_;
55             $AVAILABLE{$key} = $AVAILABLE{$_};
56             $key =~ s/:://g;
57             $AVAILABLE{$key} = $AVAILABLE{$_};
58             }
59              
60             ###############################################################################
61             #
62             # Sub Name: import
63             #
64             # Description: Method called when this module is use'd
65             #
66             # Arguments: NAME IN/OUT TYPE DESCRIPTION
67             # $class in scalar Class name (not used)
68             # @args in list Arguments to the import
69             #
70             # Globals: $PARSER_CLASS
71             #
72             # Returns: void
73             #
74             ###############################################################################
75             sub import
76             {
77 11     11   1368 my (undef, @args) = @_;
78              
79             # As a special-case, this one parameter might be specified without the
80             # key, if it is the ONLY thing passed:
81 11 50       57 if (1 == @args)
82             {
83 0         0 @args = (class => @args);
84             }
85              
86             # For now, the only arguments are key/value pairs so it's safe to coerce
87             # this into a hash
88 11         30 my %argz = @args;
89              
90             # In fact, for now, this is the only argument:
91 11 50       49 if ($argz{class})
92             {
93 0         0 $PARSER_CLASS = $argz{class};
94             }
95              
96 11         3653 return;
97             }
98              
99             ###############################################################################
100             #
101             # Sub Name: new
102             #
103             # Description: Constructor. Save any important attributes, leave the
104             # heavy lifting for the parse() routine and XML::Parser.
105             #
106             # Arguments: NAME IN/OUT TYPE DESCRIPTION
107             # $class in scalar Class we're initializing
108             # %attr in hash Any extras the caller wants
109             #
110             # Globals: $RPC::XML::ERROR
111             #
112             # Returns: Success: object ref
113             # Failure: undef
114             #
115             ###############################################################################
116             sub new
117             {
118 8     8   2114 my ($class, %attrs) = @_;
119              
120 8   66     51 my $factory = delete $attrs{class} || $PARSER_CLASS;
121              
122 8 50       45 if ($class = $AVAILABLE{$factory})
123             {
124 8         540 eval "require $class;"; ## no critic (ProhibitStringyEval)
125 8 50       128 if ($@)
126             {
127 8         82 $RPC::XML::ERROR = __PACKAGE__ . "::new: Error loading $class (" .
128             "factory for '$factory'): $@";
129 8         140 return;
130             }
131             }
132             else
133             {
134             # This means that the class is not one of the built-in ones. Try to
135             # load it, then make sure it's a sub-class of this one:
136 0           $class = $factory;
137 0           eval "require $class;"; ## no critic (ProhibitStringyEval)
138 0 0         if ($@)
139             {
140 0           $RPC::XML::ERROR = __PACKAGE__ . "::new: Error loading $class: $@";
141 0           return;
142             }
143             # Loaded OK... is it a descendent?
144 0 0         if (! $class->isa(__PACKAGE__))
145             {
146 0           $RPC::XML::ERROR = __PACKAGE__ . "::new: Class '$class' cannot " .
147             'be used, as it is not a sub-class of ' . __PACKAGE__;
148 0           return;
149             }
150             }
151              
152 0           return $class->new(%attrs);
153             }
154              
155             1;
156              
157             __END__