Upgrade to CGI.pm-3.48
[perl.git] / cpan / CGI / lib / CGI / Pretty.pm
1 package CGI::Pretty;
2
3 # See the bottom of this file for the POD documentation.  Search for the
4 # string '=head'.
5
6 # You can run this file through either pod2man or pod2html to produce pretty
7 # documentation in manual or html file format (these utilities are part of the
8 # Perl 5 distribution).
9
10 use strict;
11 use CGI ();
12
13 $CGI::Pretty::VERSION = '3.46';
14 $CGI::DefaultClass = __PACKAGE__;
15 $CGI::Pretty::AutoloadClass = 'CGI';
16 @CGI::Pretty::ISA = qw( CGI );
17
18 initialize_globals();
19
20 sub _prettyPrint {
21     my $input = shift;
22     return if !$$input;
23     return if !$CGI::Pretty::LINEBREAK || !$CGI::Pretty::INDENT;
24
25 #    print STDERR "'", $$input, "'\n";
26
27     foreach my $i ( @CGI::Pretty::AS_IS ) {
28         if ( $$input =~ m{</$i>}si ) {
29             my ( $a, $b, $c ) = $$input =~ m{(.*)(<$i[\s/>].*?</$i>)(.*)}si;
30             next if !$b;
31             $a ||= "";
32             $c ||= "";
33
34             _prettyPrint( \$a ) if $a;
35             _prettyPrint( \$c ) if $c;
36             
37             $b ||= "";
38             $$input = "$a$b$c";
39             return;
40         }
41     }
42     $$input =~ s/$CGI::Pretty::LINEBREAK/$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT/g;
43 }
44
45 sub comment {
46     my($self,@p) = CGI::self_or_CGI(@_);
47
48     my $s = "@p";
49     $s =~ s/$CGI::Pretty::LINEBREAK/$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT/g if $CGI::Pretty::LINEBREAK; 
50     
51     return $self->SUPER::comment( "$CGI::Pretty::LINEBREAK$CGI::Pretty::INDENT$s$CGI::Pretty::LINEBREAK" ) . $CGI::Pretty::LINEBREAK;
52 }
53
54 sub _make_tag_func {
55     my ($self,$tagname) = @_;
56
57     # As Lincoln as noted, the last else clause is VERY hairy, and it
58     # took me a while to figure out what I was trying to do.
59     # What it does is look for tags that shouldn't be indented (e.g. PRE)
60     # and makes sure that when we nest tags, those tags don't get
61     # indented.
62     # For an example, try print td( pre( "hello\nworld" ) );
63     # If we didn't care about stuff like that, the code would be
64     # MUCH simpler.  BTW: I won't claim to be a regular expression
65     # guru, so if anybody wants to contribute something that would
66     # be quicker, easier to read, etc, I would be more than
67     # willing to put it in - Brian
68
69     my $func = qq"
70         sub $tagname {";
71
72     $func .= q'
73             shift if $_[0] && 
74                     (ref($_[0]) &&
75                      (substr(ref($_[0]),0,3) eq "CGI" ||
76                     UNIVERSAL::isa($_[0],"CGI")));
77             my($attr) = "";
78             if (ref($_[0]) && ref($_[0]) eq "HASH") {
79                 my(@attr) = make_attributes(shift()||undef,1);
80                 $attr = " @attr" if @attr;
81             }';
82
83     if ($tagname=~/start_(\w+)/i) {
84         $func .= qq! 
85             return "<\L$1\E\$attr>\$CGI::Pretty::LINEBREAK";} !;
86     } elsif ($tagname=~/end_(\w+)/i) {
87         $func .= qq! 
88             return "<\L/$1\E>\$CGI::Pretty::LINEBREAK"; } !;
89     } else {
90         $func .= qq#
91             return ( \$CGI::XHTML ? "<\L$tagname\E\$attr />" : "<\L$tagname\E\$attr>" ) .
92                    \$CGI::Pretty::LINEBREAK unless \@_;
93             my(\$tag,\$untag) = ("<\L$tagname\E\$attr>","</\L$tagname>\E");
94
95             my \%ASIS = map { lc("\$_") => 1 } \@CGI::Pretty::AS_IS;
96             my \@args;
97             if ( \$CGI::Pretty::LINEBREAK || \$CGI::Pretty::INDENT ) {
98               if(ref(\$_[0]) eq 'ARRAY') {
99                  \@args = \@{\$_[0]}
100               } else {
101                   foreach (\@_) {
102                       \$args[0] .= \$_;
103                       \$args[0] .= \$CGI::Pretty::LINEBREAK if \$args[0] !~ /\$CGI::Pretty::LINEBREAK\$/ && 0;
104                       chomp \$args[0] if exists \$ASIS{ "\L$tagname\E" };
105                       
106                       \$args[0] .= \$" if \$args[0] !~ /\$CGI::Pretty::LINEBREAK\$/ && 1;
107                   }
108                   chop \$args[0] unless \$" eq "";
109               }
110             }
111             else {
112               \@args = ref(\$_[0]) eq 'ARRAY' ? \@{\$_[0]} : "\@_";
113             }
114
115             my \@result;
116             if ( exists \$ASIS{ "\L$tagname\E" } ) {
117                 \@result = map { "\$tag\$_\$untag" } \@args;
118             }
119             else {
120                 \@result = map { 
121                     chomp; 
122                     my \$tmp = \$_;
123                     CGI::Pretty::_prettyPrint( \\\$tmp );
124                     \$tag . \$CGI::Pretty::LINEBREAK .
125                     \$CGI::Pretty::INDENT . \$tmp . \$CGI::Pretty::LINEBREAK . 
126                     \$untag . \$CGI::Pretty::LINEBREAK
127                 } \@args;
128             }
129             if (\$CGI::Pretty::LINEBREAK || \$CGI::Pretty::INDENT) {
130                 return join ("", \@result);
131             } else {
132                 return "\@result";
133             }
134         }#;
135     }    
136
137     return $func;
138 }
139
140 sub start_html {
141     return CGI::start_html( @_ ) . $CGI::Pretty::LINEBREAK;
142 }
143
144 sub end_html {
145     return CGI::end_html( @_ ) . $CGI::Pretty::LINEBREAK;
146 }
147
148 sub new {
149     my $class = shift;
150     my $this = $class->SUPER::new( @_ );
151
152     if ($CGI::MOD_PERL) {
153         if ($CGI::MOD_PERL == 1) {
154             my $r = Apache->request;
155             $r->register_cleanup(\&CGI::Pretty::_reset_globals);
156         }
157         else {
158             my $r = Apache2::RequestUtil->request;
159             $r->pool->cleanup_register(\&CGI::Pretty::_reset_globals);
160         }
161     }
162     $class->_reset_globals if $CGI::PERLEX;
163
164     return bless $this, $class;
165 }
166
167 sub initialize_globals {
168     # This is the string used for indentation of tags
169     $CGI::Pretty::INDENT = "\t";
170     
171     # This is the string used for seperation between tags
172     $CGI::Pretty::LINEBREAK = $/;
173
174     # These tags are not prettify'd.
175     # When this list is updated, also update the docs.
176     @CGI::Pretty::AS_IS = qw( a pre code script textarea td );
177
178     1;
179 }
180 sub _reset_globals { initialize_globals(); }
181
182 # ugly, but quick fix
183 sub import {
184     my $self = shift;
185     no strict 'refs';
186     ${ "$self\::AutoloadClass" } = 'CGI';
187
188     # This causes modules to clash.
189     undef %CGI::EXPORT;
190     undef %CGI::EXPORT;
191
192     $self->_setup_symbols(@_);
193     my ($callpack, $callfile, $callline) = caller;
194
195     # To allow overriding, search through the packages
196     # Till we find one in which the correct subroutine is defined.
197     my @packages = ($self,@{"$self\:\:ISA"});
198     foreach my $sym (keys %CGI::EXPORT) {
199         my $pck;
200         my $def = ${"$self\:\:AutoloadClass"} || $CGI::DefaultClass;
201         foreach $pck (@packages) {
202             if (defined(&{"$pck\:\:$sym"})) {
203                 $def = $pck;
204                 last;
205             }
206         }
207         *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
208     }
209 }
210
211 1;
212
213 =head1 NAME
214
215 CGI::Pretty - module to produce nicely formatted HTML code
216
217 =head1 SYNOPSIS
218
219     use CGI::Pretty qw( :html3 );
220
221     # Print a table with a single data element
222     print table( TR( td( "foo" ) ) );
223
224 =head1 DESCRIPTION
225
226 CGI::Pretty is a module that derives from CGI.  It's sole function is to
227 allow users of CGI to output nicely formatted HTML code.
228
229 When using the CGI module, the following code:
230     print table( TR( td( "foo" ) ) );
231
232 produces the following output:
233     <TABLE><TR><TD>foo</TD></TR></TABLE>
234
235 If a user were to create a table consisting of many rows and many columns,
236 the resultant HTML code would be quite difficult to read since it has no
237 carriage returns or indentation.
238
239 CGI::Pretty fixes this problem.  What it does is add a carriage
240 return and indentation to the HTML code so that one can easily read
241 it.
242
243     print table( TR( td( "foo" ) ) );
244
245 now produces the following output:
246     <TABLE>
247        <TR>
248           <TD>foo</TD>
249        </TR>
250     </TABLE>
251
252 =head2 Recommendation for when to use CGI::Pretty
253
254 CGI::Pretty is far slower than using CGI.pm directly. A benchmark showed that
255 it could be about 10 times slower. Adding newslines and spaces may alter the
256 rendered appearance of HTML. Also, the extra newlines and spaces also make the
257 file size larger, making the files take longer to download.
258
259 With all those considerations, it is recommended that CGI::Pretty be used
260 primarily for debugging.
261
262 =head2 Tags that won't be formatted
263
264 The following tags are not formatted: <a>, <pre>, <code>, <script>, <textarea>, and <td>.
265 If these tags were formatted, the
266 user would see the extra indentation on the web browser causing the page to
267 look different than what would be expected.  If you wish to add more tags to
268 the list of tags that are not to be touched, push them onto the C<@AS_IS> array:
269
270     push @CGI::Pretty::AS_IS,qw(XMP);
271
272 =head2 Customizing the Indenting
273
274 If you wish to have your own personal style of indenting, you can change the
275 C<$INDENT> variable:
276
277     $CGI::Pretty::INDENT = "\t\t";
278
279 would cause the indents to be two tabs.
280
281 Similarly, if you wish to have more space between lines, you may change the
282 C<$LINEBREAK> variable:
283
284     $CGI::Pretty::LINEBREAK = "\n\n";
285
286 would create two carriage returns between lines.
287
288 If you decide you want to use the regular CGI indenting, you can easily do 
289 the following:
290
291     $CGI::Pretty::INDENT = $CGI::Pretty::LINEBREAK = "";
292
293 =head1 AUTHOR
294
295 Brian Paulsen <Brian@ThePaulsens.com>, with minor modifications by
296 Lincoln Stein <lstein@cshl.org> for incorporation into the CGI.pm
297 distribution.
298
299 Copyright 1999, Brian Paulsen.  All rights reserved.
300
301 This library is free software; you can redistribute it and/or modify
302 it under the same terms as Perl itself.
303
304 Bug reports and comments to Brian@ThePaulsens.com.  You can also write
305 to lstein@cshl.org, but this code looks pretty hairy to me and I'm not
306 sure I understand it!
307
308 =head1 SEE ALSO
309
310 L<CGI>
311
312 =cut