emacs/nxhtml/nxhtml/html-wtoc/PerlLib/html_tags.pm

   1 # Copyright 2006 Lennart Borgman, http://OurComments.org/. All rights
   2 # reserved.
   3 #
   4 # This program is free software; you can redistribute it and/or modify
   5 # it under the terms of the GNU General Public License as published by
   6 # the Free Software Foundation; either version 3, or (at your option)
   7 # any later version.
   8 #
   9 # This program is distributed in the hope that it will be useful, but
  10 # WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 # General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU General Public License
  15 # along with this program; see the file COPYING.  If not, write to the
  16 # Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  17 # Boston, MA 02110-1301, USA.
  18
  19
  20 package html_tags;
  21 use strict;
  22
  23 use vars qw($AUTOLOAD);
  24
  25 sub _make_attributes {
  26     my($self,$attr) = @_;
  27     return () unless $attr && ref($attr) && ref($attr) eq 'HASH';
  28     my(@att);
  29     foreach (keys %{$attr}) {
  30         my($key) = $_;
  31         $key=~s/^\-//;     # get rid of initial - if present
  32         #$key=~tr/a-z_/A-Z-/; # parameters are upper case, use dashes
  33         $key=~tr/A-Z_/a-z-/; # parameters are lower case in XHTML
  34         push(@att,defined($attr->{$_}) ? qq/$key="$attr->{$_}"/ : qq/$key/);
  35     }
  36     return @att;
  37 }
  38
  39 sub _tag {
  40         my $tag_name = shift;
  41         my $part     = shift;
  42         my($attr) = '';
  43         if (ref($_[0]) && ref($_[0]) eq 'HASH') {
  44                 my(@attr) = html_tags::_make_attributes( '',shift() );
  45                 $attr = " @attr" if @attr;
  46         }
  47         #return "<$tag_name$attr />" unless @_;
  48         return "<$tag_name$attr />" if $part == 1;
  49         return "<$tag_name$attr>"   if $part == 2;
  50         my($tag,$untag) = ("<$tag_name$attr\n>","</$tag_name\n>");
  51         my @result = map { "$tag$_$untag" } (ref($_[0]) eq 'ARRAY') ? @{$_[0]} : "@_";
  52         return $result[0] if $part == 1;
  53         return "@result";
  54 }
  55
  56 sub _mk_tag_sub($$) {
  57     my $name    = shift;
  58     my $package = shift;
  59     my $caller  = caller;
  60     my $sep     = ($name =~ s/^\*//);
  61     my $lc_name   = lc $name;
  62     my $code =
  63       ($lc_name =~ m/^(?:br|hr|input|img)$/ ?
  64         "sub $package\:\:$name(;\$\$) { return $caller\:\:_tag('$lc_name',1,\@_); }\n"
  65       :
  66         "sub $package\:\:$name(\$;\$) { return $caller\:\:_tag('$lc_name',0,\@_); }\n"
  67       );
  68     if ($sep) {
  69         if ($lc_name eq "html") {
  70             $code .= "sub $package\:\:start_$name(\$;\$\$)
  71                                                 {return $caller\:\:_start_html(\@_);}\n";
  72             $code .= "sub $package\:\:end_$name {return $caller\:\:_end_html();}\n";
  73         } else {
  74             $code .= "sub $package\:\:start_$name(;\$\$)
  75                                                 {return $caller\:\:_tag('$lc_name',1,\@_);}\n";
  76             $code .= "sub $package\:\:end_$name {'</$lc_name>';}\n";
  77         }
  78     }
  79     $code;
  80 }
  81 sub _start_html {
  82         my $title = shift;
  83         my $head_tags = shift;
  84         my $body_attr = shift;
  85         # compensate for perl laziness... (will not detect undef sub)
  86         $head_tags = $head_tags . _tag("title", 0, $title);
  87         my $start =
  88                 _tag("html", 2) .
  89                 _tag("head", 0, $head_tags) .
  90                 _tag("body", 2, $body_attr);
  91 }
  92 sub _end_html {
  93         return '</body></html>';
  94 }
  95
  96 sub header(@) {
  97         my @lines = @_;
  98         my $header;
  99         my $type;
 100         while (@lines) {
 101                 my $key = shift @lines; my $value = shift @lines;
 102                 $header .= "$key: $value\n";
 103                 $type = $value if $key =~ m/content-type/i;
 104         }
 105         $header .= "Content-type: text/html\n" unless defined $type;
 106         $header .= "\n";
 107 }
 108 sub import {
 109         shift;
 110         my %exported;
 111         $exported{$_}++ for (@_);
 112         my $caller = caller;
 113         my $to_eval = "package $caller;\n";
 114         for my $name (keys %exported) {
 115                 die "Will not redefine $caller\:\:$name" if $caller->can($name);
 116                 my $func;
 117                 if ($name eq "header") {
 118                         $func = "sub header { html_tags::header(); }";
 119                 }
 120                 $func = _mk_tag_sub($name, $caller) unless defined $func;
 121                 $to_eval .= "$func\n";
 122         }
 123         eval $to_eval;
 124         die $@ if $@;
 125 }
 126
 127 1;