<package name="editform">
<domain name="papp" lang="en">

<xperl><![CDATA[

=head1 NAME

macro/editform - macros used for creating html forms

=head1 SYNOPSIS

 <import src="macro/editform"/>

=head1 DESCRIPTION

This package lets you create very powerful html forms.

Unless noted otherwise, all the functions creating input elements accept
an optional additional argument which must be a hashref with additional
attribute => value pairs to use in the resulting element (see the similar
functions in L<PApp::HTML>. The C<name> attribute can optionally be
overriden.

=over 4

=cut

use Carp ();
use Convert::Scalar ();

my $EF_KEY;
my $ef_args;
my $ef_key;
my $ef_recurse;
my $ef_stateid; # stateid of currently open form
my $ef_form;    # the reference to the form html tag

sub ef_nextid($;$) {
   $EF_KEY or Carp::croak "editform called without outside ef_begin/ef_end calls\n";
   $ef_key = $_[1]{name} ||= $EF_KEY++;
   $ef_args->{"/"}{$ef_key} = $_[0] ? { ref => $_[0] } : { };
   $ef_key;
}

=item ef_mbegin [surl-arguments]

Start an editform. This directive outputs the <form> header (using
C<PApp::multipart_form>). The arguments are treated exactly like
PApp::surl arguments. If it contains callbacks or similar commands then
these will be executed AFTER the form has been processed.

If, inside C<ef_begin>/C<ef_end>, another form is embedded, the outside
form will automatically be upgraded (sbegin < cbegin < mbegin) to the most
powerful form required by the forms and the nested forms are integrated
into the surrounding form.

Please note that this doesn't work when you change the module, as only the
outside C<ef_begin> call will have the module name honoured, so always use
a C<ef_submit> to do this, or things will go very wrong.

NOTE: editform does not currently check wether a nested form specifies a;
module name. Behaviour in this case is undefined, and will most likely
result in an obscure error from surl.

=item ef_sbegin [surl-arguments]

Similar to C<ef_mbegin>, but uses C<PApp::sform> to create the form.

=item ef_cbegin [surl-arguments]

Similar to C<ef_sbegin>, but uses C<PApp::cform> to create the form.

=item ef_begin [surl-arguments]

Identical to C<ef_cbegin>, just for your convinience, as this is the form
most often used.

=item ef_end

Ends the editform. This adds the closing </form> tag.

=cut

sub _ef_parse_begin($) {
   my $ef = shift;

   $ef->{exec} = [];
}

sub _ef_parse_end($) {
   my $ef = shift;

   exists $ef->{"/"}{a}{value}
      or fancydie "form data rejected", "guard field missing (incomplete submit?)";

   &$_ for @{$ef->{cb_begin}};

   for my $field (values %{$ef->{"/"}}) {
      if (exists $field->{submit}) {
         PApp::set_alternative delete $field->{submit}
            if $field->{submit} && delete $field->{value};
      } elsif (exists $field->{checkbox}) {
         if ($field->{checkbox}) {
            if (delete $field->{value}) {
               ${$field->{ref}} |= $field->{checkbox};
            } else {
               ${$field->{ref}} &= ~$field->{checkbox};
            }
         } else {
            ${$field->{ref}} = ! ! delete $field->{value};
         }
      } elsif (exists $field->{multi}) {
         ${$field->{ref}} = delete $field->{value} || [];
      } elsif (exists $field->{ref}) {
         ${$field->{ref}} = delete $field->{value} if exists $field->{value};
         ${$field->{ref}} = $field->{constant}     if exists $field->{constant};
      }
   }

   &$_ for @{$ef->{cb_end}};
}

sub _ef_parse_field($$$) {
   my ($field, $data, $charset) = @_;

   if (exists $field->{submit}) {
      $field->{value} = 1;
   } elsif (exists $field->{ref}) {
      if ($charset) {
         $charset = lc $charset;
         if ($charset eq "utf-8") {
            Convert::Scalar::utf8_on $data;
         } elsif ($charset ne "" and $charset ne "iso-8859-1") {
            my $pconv = PApp::Recode::Pconv::open PApp::CHARSET, $charset
                           or fancydie "charset conversion from $charset not available";
            $data = Convert::Scalar::utf8_on $pconv->convert($data);
         }
         $data =~ s/\r//g;
      }

      if (exists $field->{map}) {
         $data = $data >= 0 && $data < @{$field->{map}}
               ? $field->{map}[$data]
               : fancydie "form data rejected", "security violation: selectbox value out of range";
      }

      if (exists $field->{multi}) {
         push @{$field->{value}}, $data;

      } elsif (exists $field->{checkbox}) {
         $field->{value} = 1;

      } elsif (exists $field->{password}) {
         $field->{value} = $data unless $data eq ""; # only assign nonempty inputs

      } else {
         $field->{value} = $data;
      }
   }
}

sub ef_parse_simple {
   my $ef = shift;

   _ef_parse_begin($ef);

   for my $name (keys %P) {
      if (exists $ef->{"/"}{$name}) {
         my $field = $ef->{"/"}{$name};
         my $data = $P{$name}; #FIXME# was delete $P, but that's not good for debugging#d#
         if (exists $field->{path}) {
            fancydie "file upload widgets are not supported with either ef_sbegin or ef_cbegin/ef_begin, use ef_mbegin instead";
         } else {
            for $data (ref $data ? @$data : $data) {
               $data =~ s/\r//g;
               _ef_parse_field ($field, $data, $state{papp_lcs});
            }
         }
      }
   }
   
   _ef_parse_end($ef);
}

my $ef_parse_s = register_callback {
   $request->query_string ne ""
      or fancydie "missing form data: query string empty";

   &ef_parse_simple;
} name => "papp_ef_s";

my $ef_parse_c = register_callback {
   $request->header_in("Content-Type") eq "application/x-www-form-urlencoded"
      or fancydie "missing form data: application/x-www-form-urlencoded expected, but none found";

   &ef_parse_simple;
} name => "papp_ef_c";

my $ef_parse_m = register_callback {
   my $ef = shift;

   _ef_parse_begin($ef);
   
   parse_multipart_form {
      my ($fh, $name, $ct, $cta, $cd) = @_;

      if (my $field =  $ef->{"/"}{$name}) {
         if (exists $field->{path}) {
            my $dest;
            my $path = $field->{path};

            # $ct eq "multipart/mixed" then multipart-file-upload
            # would just need to recycle PApp::FormBuffer

            $path = $path->($fh, $name, $ct, $cta, $cd) if ref $path;
            return 0 unless defined $path; # skip unless defined
            if (ref $path) {
               $dest = $path;
               undef $path;
            } else {
               open $dest, ">", "$path~"
                  or return 0;
            }
            my $size = 0;
            my $data;
            while ($fh->read($data, 64*1024) > 0) {
               $size += syswrite $dest, $data;
            }
            close $dest;
            if ($size > 0) {
               rename "$path~", $path if defined $path;
               # ok if rename worked
            } else {
               unlink "$path~" if defined $path;
               # empty file upload ignored
            }
         } else {
            my $data;
            $fh->read($data, 1024*128);
            $data =~ s/\r\n$//;

            my $charset = $ct =~ /^text\// ? $cta->{charset} : undef;

            _ef_parse_field($field, $data, $charset);
         }
      } else {
         fancydie "form data rejected", "data received for illegal field '$name'";
      }

      return 1;
   } or fancydie "missing form data: multipart/form-data expected, but none posted";

   _ef_parse_end($ef);
} name => "papp_ef_m";

sub _ef_begin {
   my $type = pop;
   my $attr = ref $_[0] eq "HASH" ? shift : {};
   if ($ef_recurse && $PApp::stateid == $ef_stateid) {
      $ef_recurse++;
      $ef_type       ||= $type;
      $ef_args->{attr} = { %$attr, %{$ef_args->{attr}} };
      push @{$ef_args->{args}}, @_;

      return "";
   } else {
      $ef_recurse = 1;
      $ef_stateid = $PApp::stateid;
      $ef_type    = $type;
      $EF_KEY     = "a";
      $ef_args    = {
         attr  => $attr,
         args  => [@_],
      };
      ($html, $ef_form) = fixup_marker;

      return $html . hidden ef_nextid(\$ef_args->{guard}), "ä";
   }
}

sub ef_sbegin* { _ef_begin @_, 1 }
sub ef_cbegin* { _ef_begin @_, 2 }
sub ef_mbegin* { _ef_begin @_, 4 }

# sub ef_begin* { # hack to get it exported
*ef_begin = *ef_cbegin;

sub ef_end* {
   $ef_recurse 
      or Carp::croak "ef_end called but no form is open";

   if (--$ef_recurse) {
      "";
   } else {
      my @args = (delete $ef_args->{attr}, @{delete $ef_args->{args}});

      $$ef_form = 
         $ef_type & 4 ? multipart_form @args, $ef_parse_m->($ef_args)
       : $ef_type & 2 ? cform          @args, $ef_parse_c->($ef_args)
       : $ef_type & 1 ? sform          @args, $ef_parse_s->($ef_args)
       : Carp::croak "editform: internal error, ef_type is $ef_type";

      # delete $ef_args->{radioref};
      undef $ef_args; # important for database accessors
      undef $EF_KEY;
      (fixup_marker endform)[0];
   }
}

=item ef_edit [group] #DEPRECATED

Returns wether the global edit-mode is active (i.e. if C<$S{ef_edit}> is
true). If the argument C<group> is given, additionally check for the stated
access right.

=cut

sub ef_edit*(;$) {
   $S{ef_edit} and (!@_ or access_p $_[0]);
}

=item ef_may_edit #DEPRECATED

Display a link that activates or de-activates global edit-mode (see
C<ef_edit>).

=cut

]]></xperl>

<macro name="ef_may_edit*"><perl><![CDATA[
   $S{ef_edit}
      ? slink __"[Leave Edit Mode]", ef_edit => undef,
      : slink __"[Enter Edit Mode]", ef_edit => 1;
]]></perl></macro>

<perl><![CDATA[

=item ef_submit [\%attrs,] $value [, surl-args...]

Output a submit button. If C<$value> is C<undef> or omitted, __"Save
Changes" is used. The rest of the arguments is interpreted in exactly the
same way as the arguments to C<PApp::surl>, with one exception: if no
destination module is given, the module destination from the C<ef_begin>
macro is used instead of overwriting the destination with the module (as
C<surl> usually does).

=item ef_reset [\%attrs,] [$value]

Output a reset button. If C<$value> is omitted, __"Restore Values" is used.

=cut

]]></perl>

<macro name="ef_submit*"><perl><![CDATA[
   my $attr = ref $_[0] eq "HASH" ? shift : {};
   my $value = shift;
   defined $value or $value = __"Save Changes";
   my $key = ef_nextid (undef, $attr);
   $ef_args->{"/"}{$key}{submit} = @_ ? &PApp::salternative : undef;
   submit $attr, $key, $value;
]]></perl></macro>

<macro name="ef_reset*"><perl><![CDATA[
   my $attr = ref $_[0] eq "HASH" ? shift : {};
   reset_button $attr, ef_nextid("reset", $attr), $_[0] || __"Restore Values";
]]></perl></macro>

<perl><![CDATA[

=item $name = ef_field fieldref [, name]

This rarely used function does not output an element itself but rather
I<registers> a field name within the editform.  If the name is omitted it
returns a newly generated name. You are responsible for creating an input
element with the given name. Since it doesn't generate an HTML element it
will of course not accept an \%attrs hash.

This can be used to implement custom input elements:

 my $name = ef_field \$self->{value};
 echo tag "input", { name => $name };

=item ef_string fieldref, [length=20]

Output a text input field.

=item ef_password fieldref, [length=20]

Output a non-readable text input field. To ensure that it is not readable,
no default text will be displayed (the reference won't be read), and only
non-empty result strings will be assigned back to the reference.

=item ef_text fieldref, width, [height]

Output a textarea tag with the given C<width> (if C<height> is omitted
C<ef_text> tries to be intelligent).

=item ef_checkbox fieldref[, bitmask]

Output a checkbox. If C<bitmask> is missing, C<fieldref> is evaluated as a
normal perl boolean. Otherwise, the C<bitmask> is used to set or clear the
given bit in the C<fieldref>.

=item ef_radio fieldref, value

Output a single radiobox that stores, when checked and submitted, "value"
in fieldref. Be careful to use the same fieldref for all radioboxes or
overwrite the name manually. C<fieldref> is compared to "value" using
C<eq>.

=item ef_button fieldref

Output an input button element.

=item ef_hidden fieldref

Output a field of type "hidden" (see also C<ef_constant> for a way to
specify constants that cannot be altered by the client, as C<ef_hidden>
cannot guarentee this).

=cut

]]></perl>

<macro name="ef_field*"><perl><![CDATA[
   return ef_nextid($_[0], { name => $_[1] });
]]></perl></macro>

<macro name="ef_string*"><perl><![CDATA[
   my $attr = ref $_[0] eq "HASH" ? shift : {};
   $attr->{size} ||= $_[1]||20;
   textfield $attr, ef_nextid($_[0], $attr), ${$_[0]};
]]></perl></macro>

<macro name="ef_password*"><perl><![CDATA[
   my $attr = ref $_[0] eq "HASH" ? shift : {};
   $attr->{size} ||= $_[1]||20;
   my $id = ef_nextid($_[0], $attr);
   $ef_args->{"/"}{$id}{password} = 1;
   password_field $attr, $id; #, ${$_[0]}; don't show anything
]]></perl></macro>

<macro name="ef_button*"><perl><![CDATA[
   my $attr = ref $_[0] eq "HASH" ? shift : {};
   button $attr, ef_nextid($_[0], $attr), ${$_[0]};
]]></perl></macro>

<macro name="ef_hidden*"><perl><![CDATA[
   my $attr = ref $_[0] eq "HASH" ? shift : {};
   hidden $attr, ef_nextid($_[0], $attr), ${$_[0]};
]]></perl></macro>

<macro name="ef_text*"><perl><![CDATA[
   my $attr = ref $_[0] eq "HASH" ? shift : {};
   $attr->{cols} ||= $_[1];
   $attr->{rows} ||= $_[2] > 0
                        ? $_[2]
                        : int (length ${$_[0]} / ($attr->{cols}-5.0001)) - $_[2]
                          + (${$_[0]} =~ y/\n/\n/);
   $attr->{wrap} ||= 'wrap';
   textarea $attr, ef_nextid($_[0], $attr), escape_html ${$_[0]};
]]></perl></macro>

<macro name="ef_checkbox*"><perl><![CDATA[
   my $attr = ref $_[0] eq "HASH" ? shift : {};
   $attr->{checked} = "checked" if $_[1] ? ${$_[0]} & $_[1] : ${$_[0]};
   my $id = ef_nextid($_[0], $attr);
   $ef_args->{"/"}{$id}{checkbox} = $_[1];
   checkbox $attr, $id;
]]></perl></macro>

<macro name="ef_radio*"><perl><![CDATA[
   my $attr = ref $_[0] eq "HASH" ? shift : {};
   $attr->{checked} = "checked" if ${$_[0]} eq $_[1];
   $attr->{name} ||= $ef_args->{radioref}{$_[0]};
   my $id = ef_nextid($_[0], $attr);
   $ef_args->{radioref}{$_[0]} = $id;
   radio $attr, $id, $_[1];
]]></perl></macro>

<perl><![CDATA[

=item ef_selectbox $ref, values...

Creates an selectbox for the given values. If $$ref evaluates to
an array-ref a multiple-select selectbox is created, otherwise a
simple single-select box is used. C<values>... can be as many C<value,
description> pairs as you like.

Beginning with version 0.143 of PApp, C<ef_selectbox> (and other functions
that use it, like C<ef_relation>) don't send the key values to the client,
but instead enumerate them and check wether submitted values are in
range. This has two consequences: first, the client can only submit valid
keys, and second, keys can be complex perl objects (like undef ;), where
they could only be strings earlier. Only arrayrefs need to be treated
differently.

Equality of key values (used to find the currently "active" selection) is
done by string comparison after stringifying the keys.

=cut

]]></perl>

<macro name="ef_selectbox*"><perl><![CDATA[
   my $attr = ref $_[0] eq "HASH" ? shift : {};
   my $field = shift;
   my $values = ref $_[0] eq "ARRAY" ? $_[0] : \@_;

   my %content;
   my $content = $$field;

   my $id = ef_nextid $field, $attr;

   if (ARRAY:: eq ref $content) {
      @content{@$content} = ();
      $attr->{multiple} = "multiple";

      $ef_args->{"/"}{$id}{multi} = 1;
   } else {
      $content{$content} = ();
   }

   my $options;
   for (my $i = 0; $i < $#$values; $i += 2) {
      push @{$ef_args->{"/"}{$id}{map}}, $$values[$i];
      $options .= "<option" .
                  (exists $content{$$values[$i]} ? " selected='selected'" : "") .
                  " value='". ($i>>1) ."'>" .
                  (escape_html $$values[$i+1]) .
                  "</option>";
   }

   xmltag "select", $attr, $options;
]]></perl></macro>

<perl><![CDATA[

=item ef_relation fieldref, relation, [key => value]...

Output relation, e.g. an selectbox with values from a sql
table. C<relation> is an arrayref containing a string (and optionally
arguments) for a select statement that must output key => value
pairs. The values will be used as display labels in an selectbox and the
corresponding key will be stored in the result field. Examples:

  ef_relation \$field, ["id, name from manufacturer order by 2"];
  ef_relation \$field, ["game_number, game_name 
                         from games where game_name like ?", "A%"];

Additional C<key> => C<value> pairs can be appended and will be used.

=item ef_set fieldref, [ table => "column" ] [mysql-specific]

Similar to C<ef_relation>, but is based on the SQL SET type, i.e. multiple
selections are possible. The field value must be of type "arrayref" for
this to work. Example:

  ef_set \$field, [game => "categories"];

=item ef_enum fieldref, [ table => "column" ] [mysql-specific]

Similar to C<ef_set>, but is based on the ENUM type in sql.

  ef_set \$field, [game => "type"];

=cut

]]></perl>

<macro name="ef_relation*"><perl><![CDATA[
   my $attr = ref $_[0] eq "HASH" ? shift : {};
   my ($field, $relation, @values) = @_;
   ref $relation eq "ARRAY" or die __"ef_relation: relation argument must be arrayref";
   unshift @$relation, $PApp::SQL::DBH unless ref $relation->[0];
   my ($dbh, $sel, @arg) = @$relation;
   my $st = sql_uexec $dbh, \my($id,$val), "select $sel", @arg;
   while ($st->fetch) {
      Convert::Scalar::utf8_on $val if Convert::Scalar::utf8_valid $val;
      push @values, $id => $val;
   }
   ef_selectbox $attr, $field, \@values;
]]></perl></macro>

<macro name="ef_set*"><perl><![CDATA[
   my $attr = ref $_[0] eq "HASH" ? shift : {};
   my ($field, $relation) = @_;
   my ($table, $fild) = @$relation;
   my $st = sql_uexec "show columns from $table like ?", $fild;
   my $type = $st->fetchrow_arrayref->[1];
   $type =~ s/^set\('(.*)'\)$/$1/ or die "ef_set: field '$fild' is not of set type\n";

   ef_selectbox $attr, $field, map {$_, $_} split /','/, $type;
]]></perl></macro>

<macro name="ef_enum*"><perl><![CDATA[
   my $attr = ref $_[0] eq "HASH" ? shift : {};
   my ($field, $relation) = @_;
   my ($table, $fild) = @$relation;
   my $st = sql_uexec "show columns from $table like ?", $fild;
   my $type = $st->fetchrow_arrayref->[1];
   $type =~ s/^enum\('(.*)'\)$/$1/ or die "ef_enum: field '$fild' is not of enum type\n";

   ef_selectbox $attr, $field, map {$_, $_} split /','/, $type;
]]></perl></macro>

<perl><![CDATA[

=item ef_file destination-path[, source-path]

Output a file upload box. The file (if submitted) will be stored as
C<destination-path>. If C<destination-path> is a coderef it will be executed
like this:

   $res = $callback->($fh, $name, $ct, $cta, $cd);

(see C<PApp::parse_multipart_form>, which uses the exact same parameters).
The return value can be undefined, in which case the file will be skipped,
a normal string which will be treated as a path to store the file to or
something else, which will be used as a file-handle.

If a destination path is given, the file will be replaced atomically (by
first writing a file with a prepended "~" and renaming (success case) or
unlinking it).

Although a source path can be given, most browsers will ignore it. Some
will display it, but not use it, so it's a rather useless feature.

C<ef_file> automatically upgrades the surrounding form to a multipart
form.

=cut

]]></perl>

<macro name="ef_file*"><perl><![CDATA[
   my $attr = ref $_[0] eq "HASH" ? shift : {};
   my $id = ef_nextid(undef, $attr);
   $ef_type |= 4;
   $ef_args->{"/"}{$id}{path} = $_[0];
   filefield $attr, $id, $_[1];
]]></perl></macro>

<perl><![CDATA[

=item ef_constant fieldref, constant

Set the field to the given C<constant>. This is useful when creating
a database row and some of the fields need to be set to a constant
value. The user cannot change this value in any way. Since this function
doesn't output an html tag it doesn't make sense to prepend an initial
hashref with additonal name => value pairs.

=cut

]]></perl>

<macro name="ef_constant*" args="$field $value"><perl><![CDATA[
   my $id = ef_nextid($field);
   $ef_args->{"/"}{$id}{constant} = $value;
]]></perl></macro>

<perl><![CDATA[

=item ef_cb_begin coderef

=item ef_cb_end coderef

Add a callback the is to be called at BEGINing or END of result
processing, i.e. call every BEGIN callback before the form results are
being processed and call every END callback after all form arguments
have been processed. All callbacks are executed in the order they were
registered (first in, first out).

=cut

]]></perl>

<macro name="ef_cb_begin*" args="$cb"><perl><![CDATA[
   push @{$ef_args->{cb_begin}}, $cb;
]]></perl></macro>

<macro name="ef_cb_end*" args="$cb"><perl><![CDATA[
   push @{$ef_args->{cb_end}}, $cb;
]]></perl></macro>

<macro name="ef_cb_end*" args="$cb"><perl><![CDATA[
   push @{$ef_args->{cb_end}}, $cb;
]]></perl></macro>

<perl><![CDATA[

=item ef_form_name

This function adds a unique C<name="id"> attribute to the opening form tag
and returns the id value to the caller. You can call it as often as you
like. If this function isn't called, no name attribute will be created.

=cut

]]></perl>

<macro name="ef_form_name*" args=""><perl><![CDATA[
   $ef_args->{attr}{name} ||= $EF_KEY++;
]]></perl></macro>

<macro name="ef_custom*" args=""><perl><![CDATA[
   $ef_args->{attr}{name} ||= $EF_KEY++;
]]></perl></macro>

<perl><![CDATA[

=back

=head1 SEE ALSO

L<PApp>

=head1 AUTHOR

 Marc Lehmann <pcg@goof.com>
 http://www.goof.com/pcg/marc/

=cut

]]></perl>

</domain>
</package>
