# ----------------- Beginning of easy.pm module. ------------------
# ------------------ Credits, info, and details. ------------------
#
# Credits
#
#   Author: Joseph K. Myers <e_mayilme@hotmail.com>
#  Version: 1
#  Updated: 7/18/2000
#
# Synopsis (Watered down version of web.pm)
#
#  Perl module relating to web development. XML compatible markup
# shortcuts, parameter handling, interesting subroutines, and other
# valuable tools. Easy interface and low overhead.




# PRIVATE VARIABLES

# hold current parameters
# and ready status
my (%data,$post,%chip,$pans,$done,$mime);

# standard shortcut list
# for multi-part tags
my @markup_tags_ = ('a','address','b','big','blockquote','button','caption','center',
'cite','code','colgroup','dd','del','dfn','dir','div','dl','dt','em','font','form',
'frameset','h1','h2','h3','h4','h5','h6','i','ins','li','map','ol','option','p','pre',
'q','s',['script', { type=>'text/javascript' }],'select','small','span','strike',
'strong',['style', { type=>'text/css' }],'sub','sup','table','tbody','td','textarea',
'tfoot','th','thead','title','tr','tt','u','ul');

# standard shortcut list
# of single-element tags
my @_inline_tags = ('area','br','col','frame','hr','img','input','link','meta','option');

# standard shortcut list
# for appropriate ones of
# "input type=..." tags
my @_form_fields = ('hidden','text','radio','checkbox');


# INITIALIZATION

# gather relevant data, generate
# shortcuts and set ready state
sub init

{

return if $done; #only run once

	$web::DOWARN = 1;

	#Let certain subroutines prevent -w errors
	#by setting $web::DOWARN to 0.
	#used by the use_tags() function
	BEGIN { $SIG{'__WARN__'} = sub { warn @_ if $web::DOWARN } }

# read query parameters (posted/query-string/stdin)
$post = &http_data(shift);
%data = ref($post) ? %{ $post } : %{ dbash($post) };

# read in available cookies
$pans = $ENV{HTTP_COOKIE};
%chip = %{ dbash($pans,';') } if $pans;

# initialize HTML tag shortcuts
use_tags(\&xml::markup,@markup_tags_);
use_tags(\&xml::inline,@_inline_tags);
use_tags(\&xml::fields,@_form_fields);

# initialization is finished
$done = 1;

}


# # # # # # # # #
 # # # # # # # #
# # # # # # # # #


# DATA MANIPULATION
# THESE FUNCTIONS WORK WITH COMPLEX REFERENCES
# AND STRUCTURES

# URL-encode data
sub encode {
my $s = defined $_[0] ? shift : return undef;
return map(encode($_),($s,@_)) if @_;
$s =~ s#[^\w.\-*@]#uc sprintf("%%%02x",ord($&))#ge;
$s;
}

# read URL-encoded data
sub decode {
my $s = defined $_[0] ? shift : return undef;
return map(decode($_),($s,@_)) if @_;
$s =~ tr/+/ /;      # pluses become spaces
$s =~ s/%([\da-fA-F]{2})/pack("c",hex($1))/ge;
$s;
}

# encode HTML entities
sub entify {
my ($s,%f) = (shift, '&'=>'amp','<'=>'lt','>'=>'gt','"'=>'quot');
return map(entify($_),($s,@_)) if @_;
$s =~ s/( & | < | > | " )/ "&$f{$1};" /gxe if defined $s;
$s;
}

# mix two hashes
sub mix {
my ($x,$y,@z) = @_;

return map(mix($_,$x),($y,@z)) if @z;
foreach (keys %$y) { $x->{$_} = $y->{$_} if !$x->{$_} }
$x;

}

# shift each element of a
# hash of arrays
sub msh {
my $h = {};
foreach (keys %{ $_[0] }) {
$_[0]->{$_} = [$_[0]->{$_}] unless ref($_[0]->{$_}) eq 'ARRAY';
next unless @{ $_[0]->{$_} };
$h->{$_} = shift(@{ $_[0]->{$_} });
} keys %$h ? $h : undef;
}

# array reference(s) to text
sub quary {
my $l = shift;
return map(quary($_), ($l,@_)) if @_;
join(',', map(encode($_), ref($l) ? @{ $l } : $l));
}

# hash reference(s) to query-string
# formatted text
sub quash {
my $q = shift;
return map(quash($_), ($q,@_)) if @_;
join('&',map( "$_=" . quary($q->{$_}), keys %$q));
}

# split up text created by quary()
sub dbary {
my $s = shift;
defined($s) && decode( split(/,/, $s) );
}

# split up text created by quash()
sub dbash {
my ($s,$p) = @_;
my %h = ();
foreach (split($p || '&',$s)) {
@_ = split('=',$_,2);
my ($n,$v) = (decode(shift),[dbary(shift)]);
unless ($h{$n}) {
	$h{$n} = $v;
	next }
push @{ $h{$n} }, @{ $v } }
\%h;
}

# expand two or more hashes of lists
# into hashes with one value per key
sub expand {

my ($d,$e,@m) = @_;
return map(expand($d,$_), ($e,@m)) if @m;

my @hash_list;
while (my $new_hash = msh($e)) {
push(@hash_list,mix($new_hash,$d));
} @hash_list ? @hash_list : ($d);

}

# convert a hash to an array
# only one value per key
sub idef {
my $a = shift;
return () unless ref($a) eq 'HASH';
map(defined($a->{$_}) ? "$_=\"" . entify($a->{$_}) . '"' : $_, sort keys %$a);
}

# convert array to hash
# of true values
sub pdef { map( ($_=>1), @_ ) }


# TEMPLATE/WRAP FUNCTIONS

# outputs from template file, replacing
# %%keywords%% with their values
sub template {

my ($filename, $fillings) = @_;
my $text;
local $/;
local *F;
open(F,"< $filename\0") || return;
$text = <F>;
close(F);
$text =~ s { %% ( .*? ) %% }
           { exists( $fillings->{$1} )
             ?       $fillings->{$1}
             :   ""
           }gesx if $fillings;
$text;

}

# wrap text to a margin, e.g.
# wrap( template('msg.txt'), 62 )
sub wrap {
my ($text, $n, $hard) = @_;
return $text unless $n-- > 0;
if ($hard) {
$text =~ s/(.{0,$n}[\s\-]|.{0,$n}\W\b|..{$n})(.+)/length $& < $n ? $& : length $2 < $n ? "$1\n$2" : "$1\n".wrap($2,$n+1)/ge;
} else {
$text =~ s/(.{0,$n}[\s\-])(.+)/length $& < $n ? $& : length $2 < $n ? "$1\n$2" : "$1\n".wrap($2,$n+1)/ge;
}
$text;
}

sub soft_wrap {
	my ($s, $m) = @_;
	$s =~ s/(.{$m,}?\b[-.,!]?)\s+/$1\n/g;
	$s;
}

# HTML/XML MARKUP FUNCTIONS

# boilerplate tag function
# generates attributes with idef()
sub tag {
my ($m,$a,$y) = ('<'.shift,@_);
foreach (idef($a)) { $m .= ' ' . $_  };
$y ? "$m>" : "$m />";
}

# boilerplate markup function
# adds on the ending tag
sub htm {
my ($n,$c,$a) = @_;
tag($n,$a,1) . $c . "</$n>";
}

# general-purpose single-element
# tag production (e.g 'img' tag)
sub xtag {
my $n = shift;
join($/, map(tag($n,$_), 
map( ref($_) eq 'ARRAY' ? expand( @{ $_ } ) : $_ , @_ ? @_ : {} ) ));
}

# general-purpose multi-part
# tag production (e.g. 'p' tag)
sub xhtm {
my ($n,$a) = (shift,shift);
join($/, map( ref($_) eq 'ARRAY' ? xhtm($n, mix(shift( @$_ ), $a), @$_) : htm($n, $_, $a),
map( ref($_) eq 'ARRAY' && !ref(@$_[0]) ? join($/, @$_) : $_, @_ ? @_ : '') ) );
}

# special-purpose form field
# tag production function
# (support for sticky values)
sub formbox {
return unless @_ > 1;
my $k = shift;
xtag('input', map( ref($_) eq 'HASH'  ? mix({ type=>$k}, $_) : ref($_) eq 'ARRAY' ? [
		{ name=>@$_[0], type=>$k },
		{ value=>[param(shift(@$_)) || @$_] } ] : [
		{ name=>$_, type=>$k },
		{ value=>[param($_)] } ],
	map( ref($_) eq 'ARRAY' && ref(@$_[0]) eq 'HASH' ? expand(@{ $_ }) : $_, @_) ));
}

# sets up the doctype
# for _head_() and _foot_()
sub doctype {
my ($doctype, %doctypes) = (shift || 'html/loose', xml=> {
	strict=>'<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
"DTD/xhtml1-strict.dtd">',
	loose=>'<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
"DTD/xhtml1-transitional.dtd">',
	frames=>'<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Frameset//EN"
"DTD/xhtml1-frameset.dtd">' }, html=> {
	strict=>'<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01//EN"
"http://www.w3.org/TR/html4/strict.dtd">',
	loose=>'<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN"
"http://www.w3.org/TR/html4/loose.dtd">',
	frames=>'<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Frameset//EN"
"http://www.w3.org/TR/html4/frameset.dtd">' } );

my @what = split('/', $doctype, 2);
$what[0] = 'html' unless $doctypes{$what[0]};
$mime = join('/', @what);
$doctypes{$what[0]}{$what[1]};
}


# SHORTCUT SUBROUTINES
# CONSTRUCTORS AND INTERFACE

# markup() is for multi-part
sub xml::markup {
my ($ns,$ls) = @_;
*{"${ns}_"} = sub { xhtm($ns, ref($_[0]) eq 'HASH' ? mix(shift, $ls) : $ls, @_) };
# eval "sub $ns\_ { xhtm ('$ns',ref(\$_[0]) eq 'HASH' ? mix(shift,\$ls) :\$ls,\@_) }";
}

# inline() is for singles
sub xml::inline {
my $ns = shift;
eval "sub _$ns { xtag ('$ns',\@_) }";
}

# fields is for form fields
sub xml::fields {
my $ns = shift;
eval "sub _$ns { formbox('$ns',\@_) }";
}

# create new shortcuts
sub use_tags {

	$web::DOWARN = 0;

my $m = shift;
return unless ref($m) eq 'CODE';
while (@_) {
my $what_tag = shift;
&$m( ref($what_tag) eq 'ARRAY' ? @{ $what_tag } : $what_tag );
}

	$web::DOWARN = 1;
}

# create an HTML comment
sub comment {
my @c = @_;
foreach (@c) {
$_ = join($/,@{ $_ }) if ref($_) eq 'ARRAY';
s/--/- -/g while /--/;
} map("<!-- $_ -->", @c);
}

# special function for
# sticky popup menus
sub popup_menu {

init();

	my ($k, $w, $n) = (shift, '', 0);
	$k = { name=>$k } unless ref($k) eq 'HASH';
	$k->{name} ||= 'menu';
	my %state = pdef param($k->{name});

select_($k, [
	map( $state{$n} ? option_( { value=>$n++, selected=>undef }, $_ ) :
		option_( { value=>$n++ }, $_ ), @_)
] );
	
}

# standard HTML top-of-page
sub _head_ {

init();

my ($m,$a) = ([],shift);
my $d = { title=>'Untitled Document', body=>{} };

$a = ref($a) eq 'HASH' ? mix($a,$d) : mix( ref($_[0]) eq 'HASH' ? mix(shift,{ title=>$a }) : { title=>$a }, $d);

if (defined $a->{doctype}) {
$a->{html} = mix($a->{html} || {}, { xmlns=>'http://www.w3.org/1999/xhtml' }) if $a->{doctype} =~ m/xml/i;
delete $a->{body} if $a->{doctype} =~ m/frames/i;
push( @{ $m }, doctype(lc $a->{doctype})) }
else { $a->{doctype} = '' }

push( @{ $m }, tag('html', $a->{html}, 1));
push( @{ $m }, xhtm('head', $a->{head}, [
htm('title',ref($a->{title}) eq 'ARRAY' ? $a->{title}[1] : $a->{title}), @_ ] ) );
push( @{ $m }, tag('body', $a->{body}, 1) ) if defined $a->{body};

join($/, @{ $m });

}

# standard HTML footer
sub _foot_ { $mime =~ m/frames/i ? '</html>' : '</body></html>' }


# CGI FUNCTIONS

# produce a simple date
# for headers, etc.
sub cgi::expire {
my ($gm,$is,$do) = (time(),@_);
$is = $gm + $is * 86400;
gmtime( $do ? $is - $is % ($do * 86400) : $is ) . '';
}

# format attributes with CGI
# syntax
sub cgi::former {
my $y = shift;
join('; ', map(ref($_) eq 'HASH' ? idef($_) : $_, @$y) ) }

# format CGI header elements
# properly
sub cgi::format {
# identifer: setting; detail="value"
my $p = shift || return '';

map ($_ . ': ' . (ref($p->{$_}) eq 'ARRAY' ? cgi::former($p->{$_})  : cgi::former([$p->{$_}])), keys %$p);
}

# produce CGI headers
sub cgi::header {
my $type = !ref($_[0]) ? shift : delete($_[0]->{type});
$type ||= 'text/html' unless defined $type;
join("\n", map(cgi::format($_), @_), $type ? "Content-Type: $type" : ()) .  "\n\n";
}

# pack cookie data for
# use in CGI headers
sub cgi::cookie {

return map(cgi::cookie(@$_), @_) if ref($_[0]) eq 'ARRAY';

my ($n,$v,$a) = @_;
return map(cgi::cookie($_,$n->{$_},$v), keys %$n) if ref($n) eq 'HASH';

$a ||= {};
$a->{expires} = cgi::expire($a->{expires}) if defined($a->{expires}) && $a->{expires} =~ m/^[\d.]+$/;
{ 'Set-Cookie'=>[ { encode($n,ref($v) eq 'HASH' ? quash($v) : $v) },  $a  ] };

}


# OFFLINE METHODS

# "alert" a message
sub alert { print STDOUT join($/, map("\n#\n\n$_\n#\n", map(ref($_) eq 'ARRAY' ? join($/, @$_) : $_, @_)) ) }

# prompt for STDIN
sub prompt {
alert(join("\n",@_));
local $/ = "\n";
chomp( my $answer = <STDIN> );
return $answer;
}


# ONLINE METHODS AND
# PARAMETER HANDLING

# combine disparate elements
# of the current query
sub http_data {

return if $done;

my @q = $ENV{QUERY_STRING} ? ($ENV{QUERY_STRING}) : ();
my $m = $ENV{REQUEST_METHOD} || '';

if ($m eq 'POST') {
read (*STDIN, my $p, $ENV{CONTENT_LENGTH});
push (@q, $p);
}

elsif (!$m) {

if (defined $_[0]) { push(@q,@_) } else {
alert('(offline mode) Enter name=value pairs to emulate online usage.');
chomp(@q = <STDIN>) }

}

sub fix_string {
$_[0] =~ s/^&|&$//;
return shift || ();
}

join('&', map( fix_string($_), @q))

}

# return parameters
sub param {

init();

my $id = defined($_[0]) ? shift : return keys %data;
return map(param($_), @_ ) if @_;

return wantarray ? () : undef unless $data{$id};
return wantarray ? @{ $data{$id} } : $data{$id}[0];

}

# get the value of a cookie
sub cookie {

init();

my $id = defined($_[0]) ? shift : return keys %chip;
return map(cookie($_), @_ ) if @_;

return wantarray ? () : undef unless $chip{$id};
return wantarray ? @{ $chip{$id} } : $chip{$id}[0];

}

1;