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 = '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 # ugly, but quick fix
 180 sub import {
 181     my $self = shift;
 182     no strict 'refs';
 183     ${ "$self\::AutoloadClass" } = 'CGI';
 184
 185     # This causes modules to clash.
 186     undef %CGI::EXPORT;
 187     undef %CGI::EXPORT;
 188
 189     $self->_setup_symbols(@_);
 190     my ($callpack, $callfile, $callline) = caller;
 191
 192     # To allow overriding, search through the packages
 193     # Till we find one in which the correct subroutine is defined.
 194     my @packages = ($self,@{"$self\:\:ISA"});
 195     foreach my $sym (keys %CGI::EXPORT) {
 196         my $pck;
 197         my $def = ${"$self\:\:AutoloadClass"} || $CGI::DefaultClass;
 198         foreach $pck (@packages) {
 199             if (defined(&{"$pck\:\:$sym"})) {
 200                 $def = $pck;
 201                 last;
 202             }
 203         }
 204         *{"${callpack}::$sym"} = \&{"$def\:\:$sym"};
 205     }
 206 }
 207
 208 1;
 209
 210 =head1 NAME
 211
 212 CGI::Pretty - module to produce nicely formatted HTML code
 213
 214 =head1 SYNOPSIS
 215
 216     use CGI::Pretty qw( :html3 );
 217
 218     # Print a table with a single data element
 219     print table( TR( td( "foo" ) ) );
 220
 221 =head1 DESCRIPTION
 222
 223 CGI::Pretty is a module that derives from CGI.  It's sole function is to
 224 allow users of CGI to output nicely formatted HTML code.
 225
 226 When using the CGI module, the following code:
 227     print table( TR( td( "foo" ) ) );
 228
 229 produces the following output:
 230     <TABLE><TR><TD>foo</TD></TR></TABLE>
 231
 232 If a user were to create a table consisting of many rows and many columns,
 233 the resultant HTML code would be quite difficult to read since it has no
 234 carriage returns or indentation.
 235
 236 CGI::Pretty fixes this problem.  What it does is add a carriage
 237 return and indentation to the HTML code so that one can easily read
 238 it.
 239
 240     print table( TR( td( "foo" ) ) );
 241
 242 now produces the following output:
 243     <TABLE>
 244        <TR>
 245           <TD>
 246              foo
 247           </TD>
 248        </TR>
 249     </TABLE>
 250
 251
 252 =head2 Tags that won't be formatted
 253
 254 The <A> and <PRE> tags are not formatted.  If these tags were formatted, the
 255 user would see the extra indentation on the web browser causing the page to
 256 look different than what would be expected.  If you wish to add more tags to
 257 the list of tags that are not to be touched, push them onto the C<@AS_IS> array:
 258
 259     push @CGI::Pretty::AS_IS,qw(CODE XMP);
 260
 261 =head2 Customizing the Indenting
 262
 263 If you wish to have your own personal style of indenting, you can change the
 264 C<$INDENT> variable:
 265
 266     $CGI::Pretty::INDENT = "\t\t";
 267
 268 would cause the indents to be two tabs.
 269
 270 Similarly, if you wish to have more space between lines, you may change the
 271 C<$LINEBREAK> variable:
 272
 273     $CGI::Pretty::LINEBREAK = "\n\n";
 274
 275 would create two carriage returns between lines.
 276
 277 If you decide you want to use the regular CGI indenting, you can easily do
 278 the following:
 279
 280     $CGI::Pretty::INDENT = $CGI::Pretty::LINEBREAK = "";
 281
 282 =head1 BUGS
 283
 284 This section intentionally left blank.
 285
 286 =head1 AUTHOR
 287
 288 Brian Paulsen <Brian@ThePaulsens.com>, with minor modifications by
 289 Lincoln Stein <lstein@cshl.org> for incorporation into the CGI.pm
 290 distribution.
 291
 292 Copyright 1999, Brian Paulsen.  All rights reserved.
 293
 294 This library is free software; you can redistribute it and/or modify
 295 it under the same terms as Perl itself.
 296
 297 Bug reports and comments to Brian@ThePaulsens.com.  You can also write
 298 to lstein@cshl.org, but this code looks pretty hairy to me and I'm not
 299 sure I understand it!
 300
 301 =head1 SEE ALSO
 302
 303 L<CGI>
 304
 305 =cut