CGI::FormBuilder::Util - Utility functions for FormBuilder

    use CGI::FormBuilder::Util;

    belch "Badness";
    puke "Egads";
    debug 2, "Debug message for level 2";

    $CGI::FormBuilder::Util::DEBUG = 1;
    debug 1, "this is printed";
    debug 2, "but not this one";

    my $table = htmltag('table', cellpadding => 1, border => 0);

    $name =~ s!\.\w+$!!;                # lose trailing ".suf"
    $name =~ s![^a-zA-Z0-9.-/]+! !g;    # strip non-alpha chars
    $name =~ s!\b(\w)!\u$1!g;           # convert _ to space/upper

    %hash  = autodata($hashref);
    @array = autodata($arrayref);

    sub field {
        my $self = shift;
        my %opt  = arghash(@_);
    }

    sub value {
        my $self = shift;
        $self->{value} = arglist(@_);

###########################################################################
# Copyright (c) 2000-2006 Nate Wiger <nate@wiger.org>. All Rights Reserved.
# Please visit www.formbuilder.org for tutorials, support, and examples.
###########################################################################

package CGI::FormBuilder::Util;

use strict;
use warnings;
no  warnings 'uninitialized';
use Carp;

# Don't "use" or it collides with our basename()
require File::Basename;

# Authoritative version information actually lives here
our $VERSION = '3.0501';
our $REVISION = do { (my $r='$Revision: 100 $') =~ s/\D+//g; $r };

# Place functions you want to export by default in the
# @EXPORT array. Any other functions can be requested
# explicitly if you place them in the @EXPORT_OK array.
use Exporter;
use base 'Exporter';
our @EXPORT = qw(
    debug belch puke indent escapeurl escapehtml escapejs
    autodata optalign optsort optval arglist arghash
    htmlattr htmltag toname tovar ismember basename rearrange
);
our $DEBUG = 0;
our %TAGNAMES = ();     # holds translated tag names (experimental)

# To clean up the HTML, instead of just allowing the HTML tags that
# we interpret are "valid", instead we yank out all the options and
# stuff that we use internally. This allows arbitrary tags to be
# specified in the generation of HTML tags, and also means that this
# module doesn't go out of date when the HTML spec changes next week.
our @OURATTR = qw(
    attr autofill autofillshow body bodyname buttonname caller checknum cleanopts 
    columns cookies comment debug delete dtd errorname extraname fields
    fieldattr fieldsubs fieldtype fieldname fieldopts fieldset fieldsets
    font force formname growable growname header idprefix inputname invalid
    javascript jsmessage jsname jsprefix jsfunc jshead jserror jsvalid keepextras
    labels labelname lalign linebreaks message messages nameopts newline other othername
    optgroups options override page pages pagename params render required
    reset resetname rowname selectname selectnum sessionidname sessionid
    smartness source sortopts static statename sticky stylesheet styleclass submit
    submitname submittedname table tabname template validate values
);

# trick for speedy lookup
our %OURATTR = map { $_ => 1 } @OURATTR;

# Have to populate ourselves to avoid carp'ing with bad information.
# This makes it so deeply-nested calls throw top-level errors, rather
# than referring to a sub-module that probably didn't do it.
our @CARP_NOT = qw(
    CGI::FormBuilder
    CGI::FormBuilder::Field
    CGI::FormBuilder::Field::button
    CGI::FormBuilder::Field::checkbox
    CGI::FormBuilder::Field::file
    CGI::FormBuilder::Field::hidden
    CGI::FormBuilder::Field::image
    CGI::FormBuilder::Field::password
    CGI::FormBuilder::Field::radio
    CGI::FormBuilder::Field::select
    CGI::FormBuilder::Field::static
    CGI::FormBuilder::Field::text
    CGI::FormBuilder::Field::textarea
    CGI::FormBuilder::Messages
    CGI::FormBuilder::Multi
    CGI::FormBuilder::Source
    CGI::FormBuilder::Source::File
    CGI::FormBuilder::Template
    CGI::FormBuilder::Template::Builtin
    CGI::FormBuilder::Template::Fast
    CGI::FormBuilder::Template::HTML
    CGI::FormBuilder::Template::TT2
    CGI::FormBuilder::Template::Text
    CGI::FormBuilder::Util
);

sub debug ($;@) {
    return unless $DEBUG >= $_[0];  # first arg is debug level
    my $l = shift;  # using $_[0] directly above is just a little faster...
    my($func) = (caller(1))[3];
    #$func =~ s/(.*)::/$1->/;
    warn "[$func] (debug$l) ", @_, "\n";
}

sub belch (@) {
    my $i=1;
    carp "[FormBuilder] Warning: ", @_;
}

sub puke (@) {
    my $i=1;
    $DEBUG ? Carp::confess("Fatal: ", @_)
           : croak "[FormBuilder] Fatal: ", @_
}

sub escapeurl ($) {
    # minimalist, not 100% correct, URL escaping
    my $toencode = shift;
    $toencode =~ s!([^a-zA-Z0-9_,.-/])!sprintf("%%%02x",ord($1))!eg;
    return $toencode;
}

sub escapehtml ($) {
    my $toencode = shift;
    return '' unless defined $toencode;
    # use very basic built-in HTML escaping
    $toencode =~ s!&!&!g;
    $toencode =~ s!<!&lt;!g;
    $toencode =~ s!>!&gt;!g;
    $toencode =~ s!"!&quot;!g;
    return $toencode;
}

sub escapejs ($) {
    my $toencode = shift;
    $toencode =~ s#'#\\'#g;
    return $toencode;
}

sub htmltag ($;@) {
    # called as htmltag('tagname', %attr)
    # creates an HTML tag on the fly, quick and dirty
    my $name = shift || return;
    my $attr = htmlattr($name, @_);     # ref return faster

    # see if we have a special tag name (experimental)
    (my $look = $name) =~ s#^(/*)##;
    $name = "$1$TAGNAMES{$look}" if $TAGNAMES{$look};

    my $htag = join(' ', $name,
                  map { qq($_=") . escapehtml($attr->{$_}) . '"' } sort keys %$attr);

    $htag .= ' /' if $name eq 'input' || $name eq 'link';  # XHTML self-closing
    return '<' . $htag . '>';
}

sub htmlattr ($;@) {
    # called as htmlattr('tagname', %attr)
    # returns valid HTML attr for that tag
    my $name = shift || return;
    my $attr = ref $_[0] ? $_[0] : { @_ };
    my %html;
    while (my($key,$val) = each %$attr) {
        # Anything but normal scalar data gets yanked
        next if ref $val || ! defined $val;

        # This cleans out all the internal junk kept in each data
        # element, returning everything else (for an html tag).
        # Crap, I used "text" here and body takes a text attr!!
        next if ($OURATTR{$key} || $key =~ /^_/
                                || ($key eq 'text'     && $name ne 'body')
                                || ($key eq 'multiple' && $name ne 'select')
                                || ($key eq 'type'     && $name eq 'select')
                                || ($key eq 'label'    && ($name ne 'optgroup' && $name ne 'option'))
                                || ($key eq 'title'    && $name eq 'form'));

        # see if we have a special tag name (experimental)
        $key = $TAGNAMES{$key} if $TAGNAMES{$key};
        $html{$key} = $val;
    }
    # "double-name" fields with an id for easier DOM scripting
    # do not override explictly set id attributes
    $html{id} = tovar($html{name}) if exists $html{name} and not exists $html{id};

    return wantarray ? %html : \%html; 
}

sub toname ($) {
    # creates a name from a var/file name (like file2name)
    my $name = shift;
    $name =~ s!\.\w+$!!;                # lose trailing ".suf"
    $name =~ s![^a-zA-Z0-9.-/]+! !g;    # strip non-alpha chars
    $name =~ s!\b(\w)!\u$1!g;           # convert _ to space/upper
    return $name;
}

sub tovar ($) {
    my $name = shift;
    $name =~ s#\W+#_#g;
    $name =~ tr/_//s;   # squish __ accidentally
    $name =~ s/_$//;    # trailing _ on "[Yo!]"
    return $name;
}

sub ismember ($@) {
    # returns 1 if is in set, undef otherwise
    # do so case-insensitively
    my $test = lc shift;
    for (@_) {
        return 1 if $test eq lc $_;
    }
    return;
}

sub autodata ($) {
    # auto-derefs appropriately
    my $data = shift;
    return unless defined $data;
    if (my $ref = ref $data) {
        if ($ref eq 'ARRAY') {
            return wantarray ? @{$data} : $data;
        } elsif ($ref eq 'HASH') {
            return wantarray ? %{$data} : $data;
        } else {
            puke "Sorry, can't handle odd data ref '$ref' (only ARRAY or HASH)";
        }
    }
    return $data;   # return as-is
}

sub arghash (;@) {
    return $_[0] if ref $_[0] && ! wantarray;

    belch "Odd number of arguments passed into ", (caller(1))[3]
       if @_ && @_ % 2 != 0;

    return wantarray ? @_ : { @_ };   # assume scalar hashref
}

sub arglist (;@) {
    return $_[0] if ref $_[0] && ! wantarray;
    return wantarray ? @_ : [ @_ ];   # assume scalar arrayref
}

sub indent (;$) {
    # return proper spaces to indent x 4 (code prettification)
    return '    ' x shift();
}

sub optalign ($) {
    # This creates and returns the options needed based
    # on an $opt array/hash shifted in
    my $opt = shift;

    # "options" are the options for our select list
    my @opt = ();
    if (my $ref = ref $opt) {
        if ($ref eq 'CODE') {
            # exec to get options
            $opt = &$opt;
        }
        # we turn any data into ( ['key', 'val'], ['key', 'val'] )
        # have to check sub-data too, hence why this gets a little nasty
        @opt = ($ref eq 'HASH')
                  ? map { (ref $opt->{$_} eq 'ARRAY')
                            ? [$_, $opt->{$_}[0]] : [$_, $opt->{$_}] } keys %{$opt}
                  : map { (ref $_ eq 'HASH')  ? [ %{$_} ] : $_ } autodata $opt;
    } else {
        # this code should not be reached, but is here for safety
        @opt = ($opt);
    }

    return @opt;
}

sub optsort ($@) {
    # pass in the sort and ref to opts
    my $sort = shift;
    my @opt  = @_;

    debug 2, "optsort($sort) called for field";

    # Currently any CODEREF can only sort on the value, which sucks if the
    # value and label are substantially different. This is caused by the fact
    # that options as specified by the user only have one element, not two
    # as hashes or generated options do. This should really be an option,
    # since sometimes you want the labels sorted too. Patches welcome.
    if ($sort eq 'alpha' || $sort eq 'name' || $sort eq 'NAME' || $sort eq 1) {
        @opt = sort { (autodata($a))[0] cmp (autodata($b))[0] } @opt;
    } elsif ($sort eq 'numeric' || $sort eq 'num' || $sort eq 'NUM') {
        @opt = sort { (autodata($a))[0] <=> (autodata($b))[0] } @opt;
    } elsif ($sort eq 'LABELNAME' || $sort eq 'LABEL') {
        @opt = sort { (autodata($a))[1] cmp (autodata($b))[1] } @opt;
    } elsif ($sort eq 'LABELNUM') {
        @opt = sort { (autodata($a))[1] <=> (autodata($b))[1] } @opt;
    } elsif (ref $sort eq 'CODE') {
        @opt = sort { eval &{$sort}((autodata($a))[0], (autodata($b))[0]) } @opt;
    } else {
        puke "Unsupported sort type '$sort' specified - must be 'NAME' or 'NUM'";
    }

    # return our options
    return @opt;
}

sub optval ($) {
    my $opt = shift;
    my @ary = (ref $opt eq 'ARRAY') ? @{$opt} : ($opt);
    return wantarray ? @ary : $ary[0];
}

sub rearrange {
    my $from = shift;
    my $name = shift;
    my $ref  = ref $from;
    my $tval;
    if ($ref && $ref eq 'HASH') {
        $tval = $from->{$name}; 
    } elsif ($ref && $ref eq 'ARRAY') {
        $tval = ismember($name, @$from) ? 1 : 0;
    } else {
        $tval = $from;
    }
    return $tval;
}

sub basename () {
    # Windows sucks so bad it's amazing to me.
    my $prog = File::Basename::basename($ENV{SCRIPT_NAME} || $0);
    $prog =~ s/\?.*//;     # lose ?p=v
    belch "Script basename() undefined somehow" unless $prog;
    return $prog;
}

1;
__END__