File Coverage

blib/lib/HTML/StickyForms.pm
Criterion Covered Total %
statement 7 145 4.8
branch 0 72 0.0
condition 0 21 0.0
subroutine 3 16 18.7
pod 12 12 100.0
total 22 266 8.2


line stmt bran cond sub pod time code
1              
2             package HTML::StickyForms;
3             BEGIN {
4 1     1   24606 $HTML::StickyForms::VERSION = '0.08';
5             }
6 1     1   8 use strict;
  1         1  
  1         23  
7 1     1   4 use warnings;
  1         1  
  1         2337  
8              
9              
10             ################################################################################
11             # Class method: new($request)
12             # Description: Return a new HTML::StickyForms object
13             # $request may be an instance of CGI (new or old) or Apache::Request
14             # Author: Peter Haworth
15             sub new{
16 0     0 1   my($class,$req)=@_;
17              
18 0           my $type;
19 0 0 0       if(!$req){
    0          
    0          
20 0           $type='empty';
21             }elsif(UNIVERSAL::isa($req,'Apache::Request')){
22 0           $type='apreq';
23             }elsif(UNIVERSAL::isa($req,'CGI') || UNIVERSAL::isa($req,'CGI::State')){
24 0           $type='CGI';
25             }else{
26             # XXX Maybe this should die?
27 0           return undef;
28             }
29              
30 0           my $self=bless {
31             req => $req,
32             type => $type,
33             values_as_labels => 0,
34             well_formed => '',
35             },$class;
36              
37             # Count submitted fields
38 0           $self->set_sticky;
39              
40 0           $self;
41             }
42              
43             ################################################################################
44             # Method: set_sticky([BOOL])
45             # Description: Count the number of parameters set in the request
46             # Author: Peter Haworth
47             sub set_sticky{
48 0     0 1   my $self=shift;
49 0 0         return $self->{params}=!!$_[0] if @_;
50              
51 0 0         $self->{params}=()=$self->{type} eq 'empty' ? () : $self->{req}->param;
52             }
53              
54             ################################################################################
55             # Method: values_as_labels([BOOL])
56             # Description: Set/Get the values_as_labels attribute
57             # Author: Peter Haworth. Idea from Thomas Klausner (domm@zsi.at)
58             sub values_as_labels{
59 0     0 1   my $self=shift;
60 0 0         return $self->{values_as_labels}=$_[0] if @_;
61 0           $self->{values_as_labels};
62             }
63              
64             ################################################################################
65             # Method: well_formed([BOOL])
66             # Description: Set/Get the well_formed attribute
67             # Author: Peter Haworth
68             sub well_formed{
69 0     0 1   my $self=shift;
70 0 0         return !!($self->{well_formed}=$_[0] ? '/' : '') if @_;
    0          
71 0           !!$self->{well_formed};
72             }
73              
74             ################################################################################
75             # Method: trim_params()
76             # Description: Trim leading and trailing whitespace from all submitted values
77             # Author: Peter Haworth
78             sub trim_params{
79 0     0 1   my($self)=@_;
80 0           my $req=$self->{req};
81 0           my $type=$self->{type};
82 0 0         return if $type eq 'empty';
83              
84 0           foreach my $k($req->param){
85 0           my @v=$req->param($k);
86 0           my $changed;
87 0           foreach(@v){
88 0           $changed+= s/^\s+//s + s/\s+$//s;
89             }
90 0 0         if($changed){
91 0 0         if($type eq 'apreq'){
92             # XXX This should work, but doesn't
93             # $req->param($k,\@v);
94              
95             # This does work, though
96 0 0         if(@v==1){
97 0           $req->param($k,$v[0]);
98             }else{
99 0           my $tab=$req->parms;
100 0           $tab->unset($k);
101 0           foreach(@v){
102 0           $tab->add($k,$_);
103             }
104             }
105             }else{
106 0           $req->param($k,@v)
107             }
108             }
109             }
110             }
111              
112             ################################################################################
113             # Subroutine: _escape($string)
114             # Description: Escape HTML-special characters in $string
115             # Author: Peter Haworth
116             sub _escape($){
117 0     0     $_[0]=~s/([<>&"\177-\377])/sprintf "&#%d;",ord $1/ge;
  0            
118             }
119              
120             ################################################################################
121             # Method: text(%args)
122             # Description: Return an HTML field
123             # Special %args elements:
124             # type => type attribute value, defaults to "text"
125             # default => value attribute value, if sticky values not present
126             # Author: Peter Haworth
127             sub text{
128 0     0 1   my($self,%args)=@_;
129 0   0       my $type=delete $args{type} || 'text';
130 0           my $name=delete $args{name};
131 0           my $value=delete $args{default};
132 0 0         $value=$self->{req}->param($name) if $self->{params};
133              
134 0           _escape($name);
135 0           _escape($value);
136              
137 0           my $field=qq(
138 0           while(my($key,$val)=each %args){
139 0           $field.=qq( $key="$val"); # XXX Escape?
140             }
141              
142 0           return "$field$self->{well_formed}>";
143             }
144              
145             ################################################################################
146             # Method: password(%args)
147             # Description: Return an HTML field
148             # As text()
149             # Author: Peter Haworth
150             sub password{
151 0     0 1   my $self=shift;
152 0           $self->text(@_,type => 'password');
153             }
154              
155             ################################################################################
156             # Method: textarea(%args)
157             # Description: Return an HTML ";
176             }
177              
178             ################################################################################
179             # Method: checkbox(%args)
180             # Description: Return a single HTML tag
181             # Special %args elements:
182             # checked => whether the box is checked, if sticky values not present
183             # Author: Peter Haworth
184             sub checkbox{
185 0     0 1   my($self,%args)=@_;
186 0           my $name=delete $args{name};
187 0           my $value=delete $args{value};
188 0           my $checked=delete $args{checked};
189 0 0         $checked=$self->{req}->param($name) eq $value if $self->{params};
190              
191 0           _escape($name);
192 0           _escape($value);
193              
194 0           my $field=qq(
195 0 0         $field.=' checked="checked"' if $checked;
196 0           while(my($key,$val)=each %args){
197 0           $field.=qq( $key="$val"); # XXX Escape?
198             }
199              
200 0           return "$field$self->{well_formed}>";
201             }
202              
203             ################################################################################
204             # Method: checkbox_group(%args)
205             # Description: Return a group of HTML tags
206             # Special %args elements:
207             # type => defaults to "checkbox"
208             # value/values => arrayref of field values, defaults to label keys
209             # label/labels => hashref of field names, no default
210             # escape => whether to escape HTML characters in labels
211             # default/defaults => arrayref of selected values, if no sticky values
212             # linebreak => whether to add
s after each checkbox
213             # values_as_labels => override the values_as_labels attribute
214             # Author: Peter Haworth
215             sub checkbox_group{
216 0     0 1   my($self,%args)=@_;
217 0   0       my $type=delete $args{type} || 'checkbox';
218 0           my $name=delete $args{name};
219 0   0       my $labels=delete $args{labels} || delete $args{label} || {};
220 0           my $escape=delete $args{escape};
221 0   0       my $values=delete $args{values} || delete $args{value} || [keys %$labels];
222 0 0         my $defaults=delete $args{exists $args{defaults} ? 'defaults' : 'default'};
223 0 0         $defaults=[] unless defined $defaults;
224 0 0         $defaults=[$defaults] if ref($defaults) ne 'ARRAY';
225 0 0         my $br=delete $args{linebreak} ? "{well_formed}>" : '';
226 0           my $v_as_l=$self->{values_as_labels};
227 0 0         if(exists $args{values_as_labels}){
228 0           $v_as_l=delete $args{values_as_labels};
229             }
230 0 0         my %checked=map { ; $_ => 1 }
  0            
231             $self->{params} ? $self->{req}->param($name) : @$defaults;
232              
233 0           _escape($name);
234              
235 0           my $field=qq(
236 0           while(my($key,$val)=each %args){
237 0           $field.=qq( $key="$val"); # XXX Escape?
238             }
239              
240 0           my @checkboxes;
241 0           for my $value(@$values){
242 0           _escape(my $evalue=$value);
243 0           my $field=qq($field value="$evalue");
244 0 0         $field.=' checked="checked"' if $checked{$value};
245 0           $field.="$self->{well_formed}>";
246 0 0 0       if((my $label=$v_as_l && !exists $labels->{$value}
    0          
247             ? $value : $labels->{$value})=~/\S/
248             ){
249 0 0         _escape($label) if $escape;
250 0           $field.=$label;
251             }
252 0           $field.=$br;
253 0           push @checkboxes,$field;
254             }
255              
256 0 0         return @checkboxes if wantarray;
257 0           return join '',@checkboxes;
258             }
259              
260             ################################################################################
261             # Method: radio_group(%args)
262             # Description: Return a group of HTML tags
263             # Special %args elements:
264             # value/values => arrayref of field values, defaults to label keys
265             # label/labels => hashref of field labels, no default
266             # escape => whether to escape HTML characters in labels
267             # defaults/default => selected value, if no sticky values
268             # linebreak => whether to add
s after each checkbox
269             # Author: Peter Haworth
270             sub radio_group{
271 0     0 1   my($self,%args)=@_;
272              
273 0           $self->checkbox_group(%args,type => 'radio');
274             }
275              
276             ################################################################################
277             # Method: select(%args)
278             # Description: Return an HTML
279             # Special %args elements:
280             # value/values => arrayref of field values, defaults to label keys
281             # label/labels => hashref of field labels, no default
282             # default/defaults => selected value(s), if no sticky values
283             # size => if positive, sets multiple
284             # values_as_labels => override the values_as_labels attribute
285             # Of little value, since this is HTML's default, anyway
286             # Author: Peter Haworth
287             sub select{
288 0     0 1   my($self,%args)=@_;
289 0           my $name=delete $args{name};
290 0           my $multiple=delete $args{multiple};
291 0   0       my $labels=delete $args{labels} || delete $args{label} || {};
292 0   0       my $values=delete $args{values} || delete $args{value} || [keys %$labels];
293 0 0         my $defaults=delete $args{exists $args{defaults} ? 'defaults' : 'default'};
294 0 0         $defaults=[] unless defined $defaults;
295 0 0         $defaults=[$defaults] if ref($defaults) ne 'ARRAY';
296 0           my $v_as_l=$self->{values_as_labels};
297 0 0         if(exists $args{values_as_labels}){
298 0           $v_as_l=delete $args{values_as_labels};
299             }
300 0 0         my %selected=map { ; $_ => 1 }
  0            
301             $self->{params} ? $self->{req}->param($name) : @$defaults;
302              
303 0           _escape($name);
304 0           my $field=qq(
305 0           while(my($key,$val)=each %args){
306 0           $field.=qq( $key="$val"); # XXX Escape?
307             }
308 0 0         $field.=' multiple="multiple"' if $multiple;
309 0           $field.=">\n";
310 0           for my $value(@$values){
311 0           _escape(my $evalue=$value);
312 0           $field.=qq(
313 0 0         $field.=' selected="selected"' if $selected{$value};
314 0           $field.=">";
315 0 0 0       if((my $label=$v_as_l && !exists $labels->{$value}
    0          
316             ? $value : $labels->{$value})=~/\S/
317             ){
318 0           _escape($label);
319 0           $field.=$label;
320             }
321 0           $field.="\n";
322             }
323 0           $field.="";
324              
325 0           $field;
326             }
327              
328             ################################################################################
329             # Return true to require
330             1;
331              
332              
333             __END__