File Coverage

lib/CGI/FormBuilder/Util.pm
Criterion Covered Total %
statement 115 134 85.8
branch 60 78 76.9
condition 55 85 64.7
subroutine 23 26 88.4
pod 20 20 100.0
total 273 343 79.5


line stmt bran cond sub pod time code
1              
2             ###########################################################################
3             # Copyright (c) Nate Wiger http://nateware.com. All Rights Reserved.
4             # Please visit http://formbuilder.org for tutorials, support, and examples.
5             ###########################################################################
6              
7             package CGI::FormBuilder::Util;
8              
9             =head1 NAME
10              
11             CGI::FormBuilder::Util - Utility functions for FormBuilder
12              
13             =head1 SYNOPSIS
14              
15             use CGI::FormBuilder::Util;
16              
17             belch "Badness";
18             puke "Egads";
19             debug 2, "Debug message for level 2";
20              
21             =head1 DESCRIPTION
22              
23             This module exports some common utility functions for B.
24             These functions are intended for internal use, however I must admit
25             that, from time to time, I just import this module and use some of
26             the routines directly (like C to generate HTML).
27              
28             =head1 USEFUL FUNCTIONS
29              
30             These can be used directly and are somewhat useful. Don't tell anyone
31             I said that, though.
32              
33             =cut
34              
35 11     11   35 use strict;
  11         11  
  11         228  
36 11     11   28 use warnings;
  11         12  
  11         194  
37 11     11   31 no warnings 'uninitialized';
  11         10  
  11         266  
38 11     11   32 use Carp;
  11         12  
  11         740  
39              
40             # Don't "use" or it collides with our basename()
41             require File::Basename;
42              
43             our $VERSION = '3.10';
44              
45             # Place functions you want to export by default in the
46             # @EXPORT array. Any other functions can be requested
47             # explicitly if you place them in the @EXPORT_OK array.
48 11     11   41 use Exporter;
  11         19  
  11         299  
49 11     11   29 use base 'Exporter';
  11         29  
  11         17484  
50             our @EXPORT = qw(
51             debug belch puke indent escapeurl escapehtml escapejs
52             autodata optalign optsort optval arglist arghash
53             htmlattr htmltag toname tovar ismember basename rearrange
54             );
55             our $DEBUG = 0;
56             our %TAGNAMES = (); # holds translated tag names (experimental)
57              
58             # To clean up the HTML, instead of just allowing the HTML tags that
59             # we interpret are "valid", instead we yank out all the options and
60             # stuff that we use internally. This allows arbitrary tags to be
61             # specified in the generation of HTML tags, and also means that this
62             # module doesn't go out of date when the HTML spec changes next week.
63             our @OURATTR = qw(
64             add_before_option add_after_option attr autofill autofillshow body bodyname
65             buttonname caller checknum cleanopts columns cookies comment debug delete
66             disable_enter dtd errorname extraname fields fieldattr fieldsubs fieldtype fieldname
67             fieldopts fieldset fieldsets font force formname growable growname header
68             idprefix inputname invalid javascript jsmessage jsname jsprefix jsfunc jshead
69             jserror jsvalid keepextras labels labelname lalign
70             linebreaks message messages nameopts newline NON_EMPTY_SCRIPT other othername
71             optgroups options override page pages pagename params render required
72             reset resetname rowname selectname selectnum sessionidname sessionid
73             smartness source sortopts static statename sticky stylesheet styleclass submit
74             submitname submittedname table tabname template validate values
75             );
76              
77             # trick for speedy lookup
78             our %OURATTR = map { $_ => 1 } @OURATTR;
79              
80             # Have to populate ourselves to avoid carp'ing with bad information.
81             # This makes it so deeply-nested calls throw top-level errors, rather
82             # than referring to a sub-module that probably didn't do it.
83             our @CARP_NOT = qw(
84             CGI::FormBuilder
85             CGI::FormBuilder::Field
86             CGI::FormBuilder::Field::button
87             CGI::FormBuilder::Field::checkbox
88             CGI::FormBuilder::Field::file
89             CGI::FormBuilder::Field::hidden
90             CGI::FormBuilder::Field::image
91             CGI::FormBuilder::Field::password
92             CGI::FormBuilder::Field::radio
93             CGI::FormBuilder::Field::select
94             CGI::FormBuilder::Field::static
95             CGI::FormBuilder::Field::text
96             CGI::FormBuilder::Field::textarea
97             CGI::FormBuilder::Messages
98             CGI::FormBuilder::Multi
99             CGI::FormBuilder::Source
100             CGI::FormBuilder::Source::File
101             CGI::FormBuilder::Template
102             CGI::FormBuilder::Template::Builtin
103             CGI::FormBuilder::Template::Fast
104             CGI::FormBuilder::Template::HTML
105             CGI::FormBuilder::Template::TT2
106             CGI::FormBuilder::Template::Text
107             CGI::FormBuilder::Template::CGI_SSI
108             CGI::FormBuilder::Util
109             );
110              
111             =head2 debug($level, $string)
112              
113             This prints out the given string only if C<$DEBUG> is greater than
114             the C<$level> specified. For example:
115              
116             $CGI::FormBuilder::Util::DEBUG = 1;
117             debug 1, "this is printed";
118             debug 2, "but not this one";
119              
120             A newline is automatically included, so don't provide one of your own.
121              
122             =cut
123              
124             sub debug ($;@) {
125 38581 50   38581 1 65833 return unless $DEBUG >= $_[0]; # first arg is debug level
126 0         0 my $l = shift; # using $_[0] directly above is just a little faster...
127 0         0 my($func) = (caller(1))[3];
128             #$func =~ s/(.*)::/$1->/;
129 0         0 warn "[$func] (debug$l) ", @_, "\n";
130             }
131              
132             =head2 belch($string)
133              
134             A modified C that prints out a better message with a newline added.
135              
136             =cut
137              
138             sub belch (@) {
139 0     0 1 0 my $i=1;
140 0         0 carp "[FormBuilder] Warning: ", @_;
141             }
142              
143             =head2 puke($string)
144              
145             A modified C that prints out a useful message.
146              
147             =cut
148              
149             sub puke (@) {
150 8     8 1 12 my $i=1;
151 8 50       1402 $DEBUG ? Carp::confess("Fatal: ", @_)
152             : croak "[FormBuilder] Fatal: ", @_
153             }
154              
155             =head2 escapeurl($string)
156              
157             Returns a properly escaped string suitable for including in URL params.
158              
159             =cut
160              
161             sub escapeurl ($) {
162             # minimalist, not 100% correct, URL escaping
163 0     0 1 0 my $toencode = shift;
164 0         0 $toencode =~ s!([^a-zA-Z0-9_,.-/])!sprintf("%%%02x",ord($1))!eg;
  0         0  
165 0         0 return $toencode;
166             }
167              
168             =head2 escapehtml($string)
169              
170             Returns an HTML-escaped string suitable for embedding in HTML tags.
171              
172             =cut
173              
174             sub escapehtml ($) {
175 5644     5644 1 4172 my $toencode = shift;
176 5644 100       6557 return '' unless defined $toencode;
177             # use very basic built-in HTML escaping
178 5624         4944 $toencode =~ s!&!&!g;
179 5624         3755 $toencode =~ s!
180 5624         3706 $toencode =~ s!>!>!g;
181 5624         3564 $toencode =~ s!"!"!g;
182 5624         11608 return $toencode;
183             }
184              
185             =head2 escapejs($string)
186              
187             Returns a string suitable for including in JavaScript. Minimal processing.
188              
189             =cut
190              
191             sub escapejs ($) {
192 400     400 1 341 my $toencode = shift;
193 400         366 $toencode =~ s#'#\\'#g;
194 400         560 return $toencode;
195             }
196              
197             =head2 htmltag($name, %attr)
198              
199             This generates an XHTML-compliant tag for the name C<$name> based on the
200             C<%attr> specified. For example:
201              
202             my $table = htmltag('table', cellpadding => 1, border => 0);
203              
204             No routines are provided to close tags; you must manually print a closing
205             C<<
>> tag. 206               207             =cut 208               209             sub htmltag ($;@) { 210             # called as htmltag('tagname', %attr) 211             # creates an HTML tag on the fly, quick and dirty 212 4419   50 4419 1 6036 my $name = shift || return; 213 4419         4781 my $attr = htmlattr($name, @_); # ref return faster 214               215             # see if we have a special tag name (experimental) 216 4419         10044 (my $look = $name) =~ s#^(/*)##; 217 4419 100       6241 $name = "$1$TAGNAMES{$look}" if $TAGNAMES{$look}; 218               219             my $htag = join(' ', $name, 220 4419         8438 map { qq($_=") . escapehtml($attr->{$_}) . '"' } sort keys %$attr);   4979         6537   221               222 4419 100 100     12397 $htag .= ' /' if $name eq 'input' || $name eq 'link'; # XHTML self-closing 223 4419         14181 return '<' . $htag . '>'; 224             } 225               226             =head2 htmlattr($name, %attr) 227               228             This cleans any internal B attributes from the specified tag. 229             It is automatically called by C. 230               231             =cut 232               233             sub htmlattr ($;@) { 234             # called as htmlattr('tagname', %attr) 235             # returns valid HTML attr for that tag 236 4548   50 4548 1 5394 my $name = shift || return; 237 4548 100       8467 my $attr = ref $_[0] ? $_[0] : { @_ }; 238 4548         3249 my %html; 239 4548         9537 while (my($key,$val) = each %$attr) { 240             # Anything but normal scalar data gets yanked 241 16605 100 100     42365 next if ref $val || ! defined $val; 242               243             # This cleans out all the internal junk kept in each data 244             # element, returning everything else (for an html tag). 245             # Crap, I used "text" here and body takes a text attr!! 246 12534 100 100     62752 next if ($OURATTR{$key} || $key =~ /^_/       66               66               100               66               66               66               66               66               33               66               66         247             || ($key eq 'text' && $name ne 'body') 248             || ($key eq 'multiple' && $name ne 'select') 249             || ($key eq 'type' && $name eq 'select') 250             || ($key eq 'label' && ($name ne 'optgroup' && $name ne 'option')) 251             || ($key eq 'title' && $name eq 'form')); 252               253             # see if we have a special tag name (experimental) 254 4931 100       5853 $key = $TAGNAMES{$key} if $TAGNAMES{$key}; 255 4931         11022 $html{$key} = $val; 256             } 257             # "double-name" fields with an id for easier DOM scripting 258             # do not override explictly set id attributes 259 4548 100 100     7823 $html{id} = tovar($html{name}) if exists $html{name} and not exists $html{id}; 260               261 4548 100       8466 return wantarray ? %html : \%html; 262             } 263               264             =head2 toname($string) 265               266             This is responsible for the auto-naming functionality of B. 267             Since you know Perl, it's easiest to just show what it does: 268               269             $name =~ s!\.\w+$!!; # lose trailing ".suf" 270             $name =~ s![^a-zA-Z0-9.-/]+! !g; # strip non-alpha chars 271             $name =~ s!\b(\w)!\u$1!g; # convert _ to space/upper 272               273             This results in something like "cgi_script.pl" becoming "Cgi Script". 274               275             =cut 276               277             sub toname ($) { 278             # creates a name from a var/file name (like file2name) 279 714     714 1 611 my $name = shift; 280 714         666 $name =~ s!\.\w+$!!; # lose trailing ".suf" 281 714         1262 $name =~ s![^a-zA-Z0-9.-/]+! !g; # strip non-alpha chars 282 714         3672 $name =~ s!\b(\w)!\u$1!g; # convert _ to space/upper 283 714         2343 return $name; 284             } 285               286             =head2 tovar($string) 287               288             Turns a string into a variable name. Basically just strips C<\W>, 289             and prefixes "fb_" on the front of it. 290               291             =cut 292               293             sub tovar ($) { 294 995     995 1 893 my $name = shift; 295 995         1436 $name =~ s#\W+#_#g; 296 995         1193 $name =~ tr/_//s; # squish __ accidentally 297 995         982 $name =~ s/_$//; # trailing _ on "[Yo!]" 298 995         1657 return $name; 299             } 300               301             =head2 ismember($el, @array) 302               303             Returns true if C<$el> is in C<@array> 304               305             =cut 306               307             sub ismember ($@) { 308             # returns 1 if is in set, undef otherwise 309             # do so case-insensitively 310 777     777 1 781 my $test = lc shift; 311 777         1061 for (@_) { 312 860 100       1462 return 1 if $test eq lc $_; 313             } 314 617         1776 return; 315             } 316               317             =head1 USELESS FUNCTIONS 318               319             These are totally useless outside of B internals. 320               321             =head2 autodata($ref) 322               323             This dereferences C<$ref> and returns the underlying data. For example: 324               325             %hash = autodata($hashref); 326             @array = autodata($arrayref); 327               328             =cut 329               330             sub autodata ($) { 331             # auto-derefs appropriately 332 2947     2947 1 2531 my $data = shift; 333 2947 100       4204 return unless defined $data; 334 2180 100       2799 if (my $ref = ref $data) { 335 1009 100       1178 if ($ref eq 'ARRAY') {     50           336 962 50       1035 return wantarray ? @{$data} : $data;   962         2099   337             } elsif ($ref eq 'HASH') { 338 47 50       68 return wantarray ? %{$data} : $data;   47         182   339             } else { 340 0         0 puke "Sorry, can't handle odd data ref '$ref' (only ARRAY or HASH)"; 341             } 342             } 343 1171         1385 return $data; # return as-is 344             } 345               346             =head2 arghash(@_) 347               348             This returns a hash of options passed into a sub: 349               350             sub field { 351             my $self = shift; 352             my %opt = arghash(@_); 353             } 354               355             It will return a hashref in scalar context. 356               357             =cut 358               359             sub arghash (;@) { 360 2148 100 66 2148 1 4586 return $_[0] if ref $_[0] && ! wantarray; 361               362 1750 50 66     4055 belch "Odd number of arguments passed into ", (caller(1))[3] 363             if @_ && @_ % 2 != 0; 364               365 1750 100       4376 return wantarray ? @_ : { @_ }; # assume scalar hashref 366             } 367               368             =head2 arglist(@_) 369               370             This returns a list of args passed into a sub: 371               372             sub value { 373             my $self = shift; 374             $self->{value} = arglist(@_); 375               376             It will return an arrayref in scalar context. 377               378             =cut 379               380             sub arglist (;@) { 381 0 0 0 0 1 0 return $_[0] if ref $_[0] && ! wantarray; 382 0 0       0 return wantarray ? @_ : [ @_ ]; # assume scalar arrayref 383             } 384               385             =head2 indent($num) 386               387             A simple sub that returns 4 spaces x C<$num>. Used to indent code. 388               389             =cut 390               391             sub indent (;$) { 392             # return proper spaces to indent x 4 (code prettification) 393 426     426 1 764 return ' ' x shift(); 394             } 395               396             =head2 optalign(\@opt) 397               398             This returns the options specified as an array of arrayrefs, which 399             is what B expects internally. 400               401             =cut 402               403             sub optalign ($) { 404             # This creates and returns the options needed based 405             # on an $opt array/hash shifted in 406 496     496 1 495 my $opt = shift; 407               408             # "options" are the options for our select list 409 496         508 my @opt = (); 410 496 100       758 if (my $ref = ref $opt) { 411 246 100       705 if ($ref eq 'CODE') { 412             # exec to get options 413 4         9 $opt = &$opt; 414             } 415             # we turn any data into ( ['key', 'val'], ['key', 'val'] ) 416             # have to check sub-data too, hence why this gets a little nasty 417             @opt = ($ref eq 'HASH') 418             ? map { (ref $opt->{$_} eq 'ARRAY') 419 0 0       0 ? [$_, $opt->{$_}[0]] : [$_, $opt->{$_}] } keys %{$opt}   0         0   420 246 100       445 : map { (ref $_ eq 'HASH') ? [ %{$_} ] : $_ } autodata $opt;   1231 50       1728     20         36   421             } else { 422             # this code should not be reached, but is here for safety 423 250         294 @opt = ($opt); 424             } 425               426 496         1123 return @opt; 427             } 428               429             =head2 optsort($sortref, @opt) 430               431             This sorts and returns the options based on C<$sortref>. It expects 432             C<@opt> to be in the format returned by C. The C<$sortref> 433             spec can be the string C, C, or a reference to a C<&sub> 434             which takes pairs of values to compare. 435               436             =cut 437               438             sub optsort ($@) { 439             # pass in the sort and ref to opts 440 18     18 1 25 my $sort = shift; 441 18         37 my @opt = @_; 442               443 18         46 debug 2, "optsort($sort) called for field"; 444               445             # Currently any CODEREF can only sort on the value, which sucks if the 446             # value and label are substantially different. This is caused by the fact 447             # that options as specified by the user only have one element, not two 448             # as hashes or generated options do. This should really be an option, 449             # since sometimes you want the labels sorted too. Patches welcome. 450 18 100 33     264 if ($sort eq 'alpha' || $sort eq 'name' || $sort eq 'NAME' || $sort eq 1) {     100 66             50 66             50 33             50 66               33         451 6         21 @opt = sort { (autodata($a))[0] cmp (autodata($b))[0] } @opt;   186         178   452             } elsif ($sort eq 'numeric' || $sort eq 'num' || $sort eq 'NUM') { 453 6         19 @opt = sort { (autodata($a))[0] <=> (autodata($b))[0] } @opt;   132         146   454             } elsif ($sort eq 'LABELNAME' || $sort eq 'LABEL') { 455 0         0 @opt = sort { (autodata($a))[1] cmp (autodata($b))[1] } @opt;   0         0   456             } elsif ($sort eq 'LABELNUM') { 457 0         0 @opt = sort { (autodata($a))[1] <=> (autodata($b))[1] } @opt;   0         0   458             } elsif (ref $sort eq 'CODE') { 459 6         18 @opt = sort { eval &{$sort}((autodata($a))[0], (autodata($b))[0]) } @opt;   300         624     300         423   460             } else { 461 0         0 puke "Unsupported sort type '$sort' specified - must be 'NAME' or 'NUM'"; 462             } 463               464             # return our options 465 18         110 return @opt; 466             } 467               468             =head2 optval($opt) 469               470             This takes one of the elements of C<@opt> and returns it split up. 471             Useless outside of B. 472               473             =cut 474               475             sub optval ($) { 476 913     913 1 650 my $opt = shift; 477 913 100       1468 my @ary = (ref $opt eq 'ARRAY') ? @{$opt} : ($opt);   206         318   478 913 50       1936 return wantarray ? @ary : $ary[0]; 479             } 480               481             =head2 rearrange($ref, $name) 482               483             Rearranges arguments designed to be per-field from the global inheritor. 484               485             =cut 486               487             sub rearrange { 488 1751     1751 1 1253 my $from = shift; 489 1751         1203 my $name = shift; 490 1751         1167 my $ref = ref $from; 491 1751         1001 my $tval; 492 1751 100 100     4271 if ($ref && $ref eq 'HASH') {     100 66         493 166         182 $tval = $from->{$name}; 494             } elsif ($ref && $ref eq 'ARRAY') { 495 126 100       185 $tval = ismember($name, @$from) ? 1 : 0; 496             } else { 497 1459         1008 $tval = $from; 498             } 499 1751         2267 return $tval; 500             } 501               502             =head2 basename 503               504             Returns the script name or $0 hacked up to the first dir 505               506             =cut 507               508             sub basename () { 509             # Windows sucks so bad it's amazing to me. 510 14   33 14 1 368 my $prog = File::Basename::basename($ENV{SCRIPT_NAME} || $0); 511 14         18 $prog =~ s/\?.*//; # lose ?p=v 512 14 50       30 belch "Script basename() undefined somehow" unless $prog; 513 14         48 return $prog; 514             } 515               516             1; 517             __END__