File Coverage

blib/lib/CGI/Form2XML.pm
Criterion Covered Total %
statement 67 109 61.4
branch 9 40 22.5
condition 7 29 24.1
subroutine 11 15 73.3
pod 8 8 100.0
total 102 201 50.7


line stmt bran cond sub pod time code
1             package CGI::Form2XML;
2              
3             =head1 NAME
4              
5             CGI::Form2XML - Render CGI form input as XML
6              
7             =head1 SYNOPSIS
8              
9              
10             use CGI::Form2XML;
11              
12              
13             my $x = CGI::Form2XML->new();
14              
15             $x->ns_prefix("nfd");
16              
17             print $x->asXML();
18              
19              
20             =head1 DESCRIPTION
21              
22             This module provides a method of taking CGI form input and turning it into
23             XML for further processing by another application or storage. Unlike
24             modules such CGI::XML and CGI::XMLForm it produces XML to a fixed schema
25             whose structure is not influenced by the form input. If flexibility as to
26             the structure of the XML data is required you will probably want to consider
27             one of the other modules.
28              
29             The schema is included in the distribution of this module as "xmlform.xsd".
30              
31             The module inherits from the CGI module in order to get access to the CGI
32             parameters, so any of the methods of that module can be used.
33              
34             =head2 METHODS
35              
36             =over 4
37              
38             =cut
39              
40 1     1   500 use strict;
  1         1  
  1         23  
41 1     1   3 use warnings;
  1         1  
  1         24  
42              
43 1     1   773 use CGI;
  1         21428  
  1         5  
44 1     1   465 use POSIX qw(strftime);
  1         4105  
  1         4  
45              
46 1     1   777 use base 'CGI';
  1         1  
  1         922  
47              
48             our $VERSION = '1.5';
49              
50             =item new
51              
52             The constructor for the class. Returns a blessed object of type CGI::Form2XML.
53             Any arguments provided will be passed to the constructor of CGI.
54              
55             =cut
56              
57             sub new
58             {
59 1     1 1 589 my ( $proto, @args) = @_;
60              
61 1   33     6 my $class = ref($proto) || $proto;
62              
63              
64 1         7 my $self = $class->SUPER::new(@args);
65              
66 1         163 bless $self, $class;
67              
68              
69 1         2 return $self;
70             }
71              
72              
73             =item asXML
74              
75             Returns the XML document that represents this CGI request.
76             It takes a hashref of arguments whose keys are :
77              
78             =over 2
79              
80             =item ns_prefix
81              
82             The namespace prefix that should be used for this document. The default
83             is no namespace.
84              
85             =item ns_url
86              
87             The URL that describes this namespace - the default is
88             'http://schemas.gellyfish.com/FormData', there is currently nothing at this
89             URL.
90              
91             =item omit_info
92              
93             If this is set to a true value then the 'header' information will not be
94             emitted by asXML().
95              
96             =back
97              
98             =cut
99              
100             sub asXML
101             {
102 1     1 1 1 my ( $self, $args ) = @_;
103              
104 1         2 my $xml = '';
105 1         1 my $info = '';
106 1         1 my $items = '';
107              
108 1         1 my $indent = ' ' x 3;
109              
110 1         2 my @params = grep !/(?:destination|session_id|owner)/, $self->param();
111              
112 1         12 my ($referer, $handler, $time, $destination, $session_id, $owner);
113              
114 1   33     4 my $ns_prefix = $args->{ns_prefix} || $self->ns_prefix();
115 1   33     4 my $ns_url = $args->{ns_url} || $self->ns_url();
116              
117 1         1 my %info;
118              
119 1 50       2 my $pref = $ns_prefix ? "$ns_prefix:" : '' ;
120              
121 1 0 33     2 unless ( $self->omit_info() || $args->{omit_info} )
122             {
123 0         0 my %mandatory = (
124             referer => 1,
125             handler => 1,
126             timestamp => 1
127             );
128              
129 0   0     0 $info{referer} = $self->referer() || '';
130 0   0     0 $info{handler} = $self->script_name() || '';
131              
132 0         0 $info{timestamp} = strftime("%Y-%d-%mT%H:%M:%S",localtime());
133              
134              
135 0   0     0 $info{destination} = $self->param('destination') || $self->destination()
136             || '';
137 0   0     0 $info{session_id} = $self->param('session_id') || $self->sess_id() || '';
138 0   0     0 $info{owner} = $self->param('owner') || $self->owner() || '' ;
139              
140            
141              
142            
143 0         0 for my $item ( keys %info )
144             {
145 0         0 my $indent = $indent x 2;
146            
147 0 0       0 if ( length $info{$item} )
    0          
148             {
149 0         0 $info{$item} = _quote_xml($info{$item});
150            
151 0         0 $info .= "$indent<$pref$item>$info{$item}\n";
152             }
153             elsif ($mandatory{$item})
154             {
155 0         0 $info .= "$indent<$pref$item />\n";
156             }
157             }
158              
159 0         0 $info = "$indent<${pref}info>\n$info$indent\n";
160             }
161              
162 1         2 foreach my $param ( @params )
163             {
164 1         2 my $indent = $indent x 2;
165              
166 1         2 my $value = $self->param($param);
167              
168 1 50       14 if (ref $value )
169             {
170 0         0 my $index = 0;
171 0         0 foreach my $mvalue ( @{$value} )
  0         0  
172             {
173 0         0 $index++;
174 0         0 $mvalue = _quote_xml($mvalue);
175 0         0 $items .= qq%$indent<${pref}field name="$param" index="$index">%;
176 0         0 $items .= "$mvalue\n";
177             }
178             }
179             else
180             {
181 1         1 $value = _quote_xml($value);
182 1         3 $items .= qq%$indent<${pref}field name="$param">%;
183 1         2 $items .= "$value\n";
184             }
185             }
186              
187 1         2 $items = "$indent<${pref}items>\n$items$indent\n";
188              
189 1         1 my $ns_att = '';
190              
191            
192 1 50       2 if ( $ns_url )
193             {
194              
195 1         0 my $prefix_part = '';
196              
197 1 50       5 if ($ns_prefix )
198             {
199 1         1 $prefix_part = ":$ns_prefix";
200             }
201 1         2 $ns_att = qq% xmlns$prefix_part="$ns_url"%;
202             }
203              
204 1         2 $xml = "<${pref}form_data$ns_att>\n$info$items\n";
205              
206 1         3 return $xml;
207             }
208              
209             =item ns_prefix
210              
211             Gets and/or sets the namespace prefix as described as an argument to asXML()
212             above.
213              
214             =cut
215              
216             sub ns_prefix
217             {
218 3     3 1 282 my ( $self, $ns_prefix ) = @_;
219              
220 3 100       7 if ( defined $ns_prefix )
221             {
222 1         2 $self->{_private}->{ns_prefix} = $ns_prefix;
223             }
224            
225 3   50     12 return $self->{_private}->{ns_prefix} || '';
226             }
227              
228             =item ns_url
229              
230             Returns and/or sets the namespace URL for the document as described as an
231             argument to asXML() above.
232              
233             =cut
234              
235             sub ns_url
236             {
237 1     1 1 1 my ( $self, $ns_url ) = @_;
238              
239 1 50       1 if ( defined $ns_url )
240             {
241 0         0 $self->{_private}->{ns_url} = $ns_url;
242             }
243            
244 1         1 my $def_url = 'http://schemas.gellyfish.com/FormData';
245              
246 1   33     5 return $self->{_private}->{ns_url} || $def_url;
247              
248             }
249              
250             =item omit_info
251              
252             If this is set to a true value then the 'header' information will not be
253             emitted in the output document.
254              
255             =cut
256              
257             sub omit_info
258             {
259 3     3 1 5 my ( $self, $omit_info ) = @_;
260              
261 3 100       6 if ( defined $omit_info )
262             {
263 1         2 $self->{_private}->{omit_info} = $omit_info;
264             }
265              
266 3   50     8 return $self->{_private}->{omit_info} || 0;
267              
268             }
269              
270             =item destination
271              
272             This is used to set the value of the 'destination' element in the header
273             information of the output document. This may be a URL, email address or
274             some other identifier. Its content is entirely application specific.
275              
276             =cut
277              
278             sub destination
279             {
280 0     0 1 0 my ( $self, $destination ) = @_;
281              
282 0 0       0 if ( defined $destination )
283             {
284 0         0 $self->{_private}->{destination} = $destination;
285             }
286              
287             return exists $self->{_private}->{destination} ?
288 0 0       0 $self->{_private}->{destination} : '';
289             }
290              
291             =item sess_id
292              
293             This sets the 'session id' for this CGI request, it is intended to be a
294             unique identifier for this request and may take the form of a UUID or an
295             MD5 hash or something similar. Its use is application specific.
296              
297             =cut
298              
299             sub sess_id
300             {
301 0     0 1 0 my ( $self , $sess_id ) = @_;
302              
303 0 0       0 if ( defined $sess_id )
304             {
305 0         0 $self->{_private}->{sess_id} = $sess_id;
306             }
307              
308             return exists $self->{_private}->{sess_id} ?
309 0 0       0 $self->{_private}->{sess_id} : '' ;
310              
311             }
312              
313             =item owner
314              
315             This sets the value of the 'owner' element in the header information. This
316             is intended to be the e-mail address indicating the contact for this
317             application. The usage of this information is application specific.
318              
319             =cut
320              
321             sub owner
322             {
323 0     0 1 0 my ( $self , $owner ) = @_;
324              
325 0 0       0 if ( defined $owner )
326             {
327 0         0 $self->{_private}->{owner} = $owner;
328             }
329              
330             return exists $self->{_private}->{owner} ?
331 0 0       0 $self->{_private}->{owner} : '' ;
332              
333             }
334              
335             sub _quote_xml
336             {
337 1     1   2 $_[0] =~ s/&/&/g;
338 1         0 $_[0] =~ s/
339 1         14 $_[0] =~ s/>/>/g;
340 1         1 $_[0] =~ s/'/'/g;
341 1         1 $_[0] =~ s/"/"/g;
342 1         2 $_[0] =~ s/([\x80-\xFF])/&XmlUtf8Encode(ord($1))/ge;
  0         0  
343 1         1 return($_[0]);
344             }
345              
346             # I borrowed this from CGI::XML which in turn said
347             # borrowed from XML::DOM
348              
349             sub _xml_utf8_encode
350             {
351 0     0     my ($n) = @_;
352 0 0         if ($n < 0x80)
    0          
    0          
    0          
353             {
354 0           return chr ($n);
355             }
356             elsif ($n < 0x800)
357             {
358 0           return pack ("CC", (($n >> 6) | 0xc0), (($n & 0x3f) | 0x80));
359             }
360             elsif ($n < 0x10000)
361             {
362 0           return pack ("CCC", (($n >> 12) | 0xe0), ((($n >> 6) & 0x3f) | 0x80),
363             (($n & 0x3f) | 0x80));
364             }
365             elsif ($n < 0x110000)
366             {
367 0           return pack ("CCCC", (($n >> 18) | 0xf0), ((($n >> 12) & 0x3f) | 0x80),
368             ((($n >> 6) & 0x3f) | 0x80), (($n & 0x3f) | 0x80));
369             }
370              
371 0           return $n;
372             }
373              
374             =back
375              
376             =cut
377              
378             1;
379             __END__