ext/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.44';
  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\$CGI::Pretty::LINEBREAK" }
 118                  \@args;
 119             }
 120             else {
 121                 \@result = map {
 122                     chomp;
 123                     my \$tmp = \$_;
 124                     CGI::Pretty::_prettyPrint( \\\$tmp );
 125                     \$tag . \$CGI::Pretty::LINEBREAK .
 126                     \$CGI::Pretty::INDENT . \$tmp . \$CGI::Pretty::LINEBREAK .
 127                     \$untag . \$CGI::Pretty::LINEBREAK
 128                 } \@args;
 129             }
 130             if (\$CGI::Pretty::LINEBREAK || \$CGI::Pretty::INDENT) {
 131                 return join ("", \@result);
 132             } else {
 133                 return "\@result";
 134             }
 135         }#;
 136     }
 137
 138     return $func;
 139 }
 140
 141 sub start_html {
 142     return CGI::start_html( @_ ) . $CGI::Pretty::LINEBREAK;
 143 }
 144
 145 sub end_html {
 146     return CGI::end_html( @_ ) . $CGI::Pretty::LINEBREAK;
 147 }
 148
 149 sub new {
 150     my $class = shift;
 151     my $this = $class->SUPER::new( @_ );
 152
 153     if ($CGI::MOD_PERL) {
 154         if ($CGI::MOD_PERL == 1) {
 155             my $r = Apache->request;
 156             $r->register_cleanup(\&CGI::Pretty::_reset_globals);
 157         }
 158         else {
 159             my $r = Apache2::RequestUtil->request;
 160             $r->pool->cleanup_register(\&CGI::Pretty::_reset_globals);
 161         }
 162     }
 163     $class->_reset_globals if $CGI::PERLEX;
 164
 165     return bless $this, $class;
 166 }
 167
 168 sub initialize_globals {
 169     # This is the string used for indentation of tags
 170     $CGI::Pretty::INDENT = "\t";
 171
 172     # This is the string used for seperation between tags
 173     $CGI::Pretty::LINEBREAK = $/;
 174
 175     # These tags are not prettify'd.
 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>
 249              foo
 250           </TD>
 251        </TR>
 252     </TABLE>
 253
 254
 255 =head2 Tags that won't be formatted
 256
 257 The <A> and <PRE> tags are not formatted.  If these tags were formatted, the
 258 user would see the extra indentation on the web browser causing the page to
 259 look different than what would be expected.  If you wish to add more tags to
 260 the list of tags that are not to be touched, push them onto the C<@AS_IS> array:
 261
 262     push @CGI::Pretty::AS_IS,qw(CODE XMP);
 263
 264 =head2 Customizing the Indenting
 265
 266 If you wish to have your own personal style of indenting, you can change the
 267 C<$INDENT> variable:
 268
 269     $CGI::Pretty::INDENT = "\t\t";
 270
 271 would cause the indents to be two tabs.
 272
 273 Similarly, if you wish to have more space between lines, you may change the
 274 C<$LINEBREAK> variable:
 275
 276     $CGI::Pretty::LINEBREAK = "\n\n";
 277
 278 would create two carriage returns between lines.
 279
 280 If you decide you want to use the regular CGI indenting, you can easily do
 281 the following:
 282
 283     $CGI::Pretty::INDENT = $CGI::Pretty::LINEBREAK = "";
 284
 285 =head1 BUGS
 286
 287 This section intentionally left blank.
 288
 289 =head1 AUTHOR
 290
 291 Brian Paulsen <Brian@ThePaulsens.com>, with minor modifications by
 292 Lincoln Stein <lstein@cshl.org> for incorporation into the CGI.pm
 293 distribution.
 294
 295 Copyright 1999, Brian Paulsen.  All rights reserved.
 296
 297 This library is free software; you can redistribute it and/or modify
 298 it under the same terms as Perl itself.
 299
 300 Bug reports and comments to Brian@ThePaulsens.com.  You can also write
 301 to lstein@cshl.org, but this code looks pretty hairy to me and I'm not
 302 sure I understand it!
 303
 304 =head1 SEE ALSO
 305
 306 L<CGI>
 307
 308 =cut