lib/perl5/5.8.8/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 = '1.08';
  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];
 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             local \$" = "" if \$CGI::Pretty::LINEBREAK || \$CGI::Pretty::INDENT;
 131             return "\@result";
 132         }#;
 133     }
 134
 135     return $func;
 136 }
 137
 138 sub start_html {
 139     return CGI::start_html( @_ ) . $CGI::Pretty::LINEBREAK;
 140 }
 141
 142 sub end_html {
 143     return CGI::end_html( @_ ) . $CGI::Pretty::LINEBREAK;
 144 }
 145
 146 sub new {
 147     my $class = shift;
 148     my $this = $class->SUPER::new( @_ );
 149
 150     if ($CGI::MOD_PERL) {
 151         if ($CGI::MOD_PERL == 1) {
 152             my $r = Apache->request;
 153             $r->register_cleanup(\&CGI::Pretty::_reset_globals);
 154         }
 155         else {
 156             my $r = Apache2::RequestUtil->request;
 157             $r->pool->cleanup_register(\&CGI::Pretty::_reset_globals);
 158         }
 159     }
 160     $class->_reset_globals if $CGI::PERLEX;
 161
 162     return bless $this, $class;
 163 }
 164
 165 sub initialize_globals {
 166     # This is the string used for indentation of tags
 167     $CGI::Pretty::INDENT = "\t";
 168
 169     # This is the string used for seperation between tags
 170     $CGI::Pretty::LINEBREAK = $/;
 171
 172     # These tags are not prettify'd.
 173     @CGI::Pretty::AS_IS = qw( a pre code script textarea td );
 174
 175     1;
 176 }
 177 sub _reset_globals { initialize_globals(); }
 178
 179 1;
 180
 181 =head1 NAME
 182
 183 CGI::Pretty - module to produce nicely formatted HTML code
 184
 185 =head1 SYNOPSIS
 186
 187     use CGI::Pretty qw( :html3 );
 188
 189     # Print a table with a single data element
 190     print table( TR( td( "foo" ) ) );
 191
 192 =head1 DESCRIPTION
 193
 194 CGI::Pretty is a module that derives from CGI.  It's sole function is to
 195 allow users of CGI to output nicely formatted HTML code.
 196
 197 When using the CGI module, the following code:
 198     print table( TR( td( "foo" ) ) );
 199
 200 produces the following output:
 201     <TABLE><TR><TD>foo</TD></TR></TABLE>
 202
 203 If a user were to create a table consisting of many rows and many columns,
 204 the resultant HTML code would be quite difficult to read since it has no
 205 carriage returns or indentation.
 206
 207 CGI::Pretty fixes this problem.  What it does is add a carriage
 208 return and indentation to the HTML code so that one can easily read
 209 it.
 210
 211     print table( TR( td( "foo" ) ) );
 212
 213 now produces the following output:
 214     <TABLE>
 215        <TR>
 216           <TD>
 217              foo
 218           </TD>
 219        </TR>
 220     </TABLE>
 221
 222
 223 =head2 Tags that won't be formatted
 224
 225 The <A> and <PRE> tags are not formatted.  If these tags were formatted, the
 226 user would see the extra indentation on the web browser causing the page to
 227 look different than what would be expected.  If you wish to add more tags to
 228 the list of tags that are not to be touched, push them onto the C<@AS_IS> array:
 229
 230     push @CGI::Pretty::AS_IS,qw(CODE XMP);
 231
 232 =head2 Customizing the Indenting
 233
 234 If you wish to have your own personal style of indenting, you can change the
 235 C<$INDENT> variable:
 236
 237     $CGI::Pretty::INDENT = "\t\t";
 238
 239 would cause the indents to be two tabs.
 240
 241 Similarly, if you wish to have more space between lines, you may change the
 242 C<$LINEBREAK> variable:
 243
 244     $CGI::Pretty::LINEBREAK = "\n\n";
 245
 246 would create two carriage returns between lines.
 247
 248 If you decide you want to use the regular CGI indenting, you can easily do
 249 the following:
 250
 251     $CGI::Pretty::INDENT = $CGI::Pretty::LINEBREAK = "";
 252
 253 =head1 BUGS
 254
 255 This section intentionally left blank.
 256
 257 =head1 AUTHOR
 258
 259 Brian Paulsen <Brian@ThePaulsens.com>, with minor modifications by
 260 Lincoln Stein <lstein@cshl.org> for incorporation into the CGI.pm
 261 distribution.
 262
 263 Copyright 1999, Brian Paulsen.  All rights reserved.
 264
 265 This library is free software; you can redistribute it and/or modify
 266 it under the same terms as Perl itself.
 267
 268 Bug reports and comments to Brian@ThePaulsens.com.  You can also write
 269 to lstein@cshl.org, but this code looks pretty hairy to me and I'm not
 270 sure I understand it!
 271
 272 =head1 SEE ALSO
 273
 274 L<CGI>
 275
 276 =cut