site/cgi-bin/modules/DevHelp/HTML.pm

   1 package DevHelp::HTML;
   2 use strict;
   3 use Carp qw(confess);
   4
   5 our $VERSION = "1.000";
   6
   7 require Exporter;
   8 use vars qw(@EXPORT_OK @EXPORT @ISA %EXPORT_TAGS);
   9 @EXPORT_OK = qw(escape_html escape_uri unescape_html unescape_uri popup_menu escape_xml);
  10 @EXPORT = qw(escape_html escape_uri unescape_html unescape_uri);
  11 %EXPORT_TAGS =
  12   (
  13    all => \@EXPORT_OK,
  14    default => \@EXPORT,
  15   );
  16 @ISA = qw(Exporter);
  17
  18 use HTML::Entities ();
  19 use URI::Escape ();
  20
  21 sub escape_html {
  22   my ($text, $what) = @_;
  23
  24   $what ||= '<>&"\x7F';
  25
  26   HTML::Entities::encode($text, $what);
  27 }
  28
  29 sub unescape_html {
  30   HTML::Entities::decode(shift);
  31 }
  32
  33 my %xml_entities = qw(< lt > gt & amp " quot);
  34
  35 sub escape_xml {
  36   my ($text) = @_;
  37
  38   $text =~ s/([<>&\"\x7F])/$xml_entities{$1} ? "&$xml_entities{$1};" : "&#".ord($1).";"/ge;
  39
  40   return $text;
  41 }
  42
  43 sub escape_uri {
  44   # older versions of uri_escape() acted differently without the
  45   # second argument, so supply one to make sure we escape what
  46   # needs escaping
  47   URI::Escape::uri_escape(shift, "^A-Za-z0-9\-_.!~*()");
  48 }
  49
  50 sub unescape_uri {
  51   URI::Escape::uri_unescape(shift);
  52 }
  53
  54 sub _options {
  55   my ($values, $labels, $default) = @_;
  56
  57   my $html = '';
  58   for my $value (@$values) {
  59     my $option = '<option value="' . escape_html($value) . '"';
  60     my $label = $labels->{$value};
  61     defined $label or $label = $value;
  62     $option .= ' selected="selected"'
  63       if defined($default) && $default eq $value;
  64     $option .= '>' . escape_html($label) . "</option>";
  65     $html .= $option . "\n";
  66   }
  67
  68   return $html;
  69 }
  70
  71 sub popup_menu {
  72   my (%opts) = @_;
  73
  74   exists $opts{'-name'}
  75     or confess "No -name parameter";
  76
  77   my $html = '<select name="' . escape_html($opts{"-name"}) . '"';
  78   $html .= ' id="'.escape_html($opts{'-id'}).'"' if $opts{'-id'};
  79   $html .= '>';
  80   my $labels = $opts{"-labels"} || {};
  81   my $values = $opts{"-values"};
  82   my $default = $opts{"-default"};
  83   my $groups = $opts{"-groups"};
  84   if ($groups) {
  85     for my $group (@$groups) {
  86       my ($label, $ids) = @$group;
  87       if (length $label) {
  88         $html .= '<optgroup label="' . escape_html($label) . '">'
  89           . _options($ids, $labels, $default) . '</optgroup>';
  90       }
  91       else {
  92         $html .= _options($ids, $labels, $default);
  93       }
  94     }
  95   }
  96   else {
  97     $html .= _options($values, $labels, $default);
  98   }
  99   $html .= "</select>";
 100
 101   $html;
 102 }
 103
 104 1;
 105
 106 __END__
 107
 108 =head1 NAME
 109
 110 DevHelp::HTML - provides simple consistent interfaces to HTML/URI
 111 escaping with some extras
 112
 113 =head1 SYNOPSIS
 114
 115   use DevHelp::HTML;
 116
 117   my $escaped = escape_html($text);
 118   my $escaped = escape_uri($text);
 119   my $unescaped = unescape_html($text);
 120   my $unescaped = unescape_uri($text);
 121   my $html = popup_menu(-name => $name,
 122                         -values => \@values,
 123                         -labels => \%labels,
 124                         -default => $default);
 125
 126 =head1 DESCRIPTION
 127
 128 Provides some of the functionality of the CGI.pm module, without the
 129 code to get the query/POST parameters.
 130
 131 =over
 132
 133 =item escape_html($text)
 134
 135 Converts characters that should be entities into entities.  Don't
 136 expect this to work with UTF-8 text.  Unlike the native HTML::Entities
 137 interface it won't convert CR (\x0D) into an entity, since this causes
 138 problems.
 139
 140 Probably assumes Latin-1.
 141
 142 =item escape_uti($text)
 143
 144 URI escapes $text.
 145
 146 =item unescape_html($text)
 147
 148 Unescape entities.
 149
 150 =item unescape_uri($text)
 151
 152 Unescape URI escaped text.
 153
 154 =item popup_menu(...)
 155
 156 Creates a C<select> form element.  Same interface as CGI::popup_menu()
 157 but without the need to use -override to make the -default option
 158 useful.
 159
 160 =back
 161
 162 =head1 AUTHOR
 163
 164 Tony Cook <tony@develop-help.com>
 165
 166 =cut