package Maypole::Model::CDBI::AsForm;

use 5.006;

use strict;
use warnings;

use base 'Exporter';
use Data::Dumper;
use Class::DBI::Plugin::Type ();
use HTML::Element;

our $OLD_STYLE = 0;
# pjs  --  Added new methods to @EXPORT 
our @EXPORT = 
	qw( 
		to_cgi to_field  make_element_foreign unselect_element
		_field_from_how _field_from_relationship _field_from_column
		_to_textarea _to_textfield _to_select _select_guts
		_to_foreign_inputs _to_enum_select _to_bool_select
		_to_hidden _to_link_hidden _rename_foreign_input _to_readonly
		_options_from_objects _options_from_arrays _options_from_hashes 
		_options_from_scalars
    );
				
our @EXPORTOK = 
	qw( 
		
        
	);
				  
				  

our $VERSION = '.09'; 
# Changes :
# 08-09-05 - fixed broken has_a select box 
#          - fiked some docs
#          - _to_foreign_inputs now takes 3 positional parameters 
#            (accssr,  fields, accssr_meta_info)

# 10-18-05 - made _to_enum_select check column_default
# 10-19-05 - exported _to_select_from_objs
#          - Now VERSION .06
# 10-24-05 - _to_select_from_many Redesign.
#            Now first arg is either a has_many  accessor or a array ref of
#            objects to select from and the options are in named list .
#              selected : object or id
#              name     : the element name
#    to_select_from_many ($accssr|$objs [, selected => $obj|$id, name => $elmnt_name])
#
#           - _to_hidden -- if object arg then name and value are from pk
#           _ _rename_foreign_input -- took out useless assignment on new name
#           - _to_select : put empty option if column is nullable
# 11-04-05  - _to_readonly with no args makes the calling object pk and id
#           - _to_select : if object calls it without a column argument, it make#      s a select box of the calling class rows and the object is pre selected.
#
# 11-05-05  - added _to_link_hidden  to make a link to the hidden object
#           - fixed _to_hidden when called with no args. Hides self obj.
# 11-04-05  - _to_textfield: tries to call "deflate4edit" if column is has_a
# 11-08-05  - Changed Version to .08



# 1-10-06  -- fixed bug in to_textfiled that was stringifyingf CDBI objects
# #
#
# 1-20-06  - to_select - call db_Main with has a class.
# 1-24-06  - to_select_from_many now named _to_select_from_many . Old deprecated
#          - hasmany_class removed in favor of model's related_class method. 
#		   - took out do_select. That is a model action.
#          - use search_columns instead of  search_fields now.
#          - use to_field('column', 'select', {args}) instead of a_select_box.
#          -- took out make_hidden_element.was my own personal hack
#          -- added _box from DH's FormView to calculate decent textarea size
#          -- Refactor to_field into _from_* method calls.
#          
# 1-25-06  -- Added _to_checkbox and _to_radio from FView
# 1-27-06  -- Refactored into yet more exported  methods
# 1-28-06  -- select constraints where, join order by 
# 2-16-05  -- select box cols should only contain pks if you want them to
#             be in he content string of the option. Went backt to old way.
#


=head1 NAME

Maypole::Model:CDBI::AsForm - Produce HTML form elements for database columns

=head1 SYNOPSIS

    package Music::CD;
    use Maypole::Model::CDBI::AsForm;
    use base 'Class::DBI';
    use CGI;
    ...

    sub create_or_edit {
        my $self = shift;
        my %cgi_field = $self->to_cgi;
        return start_form,
               (map { "<b>$_</b>: ". $cgi_field{$_}->as_HTML." <br>" } 
                    $class->Columns),
               end_form;
    }

	. . . somewhere use to_field($col, $how, $args)
	package BeerDB::Pint;
	__PACKAGE__->has_a('drinker', 'BeerDB::Drinker');
	__PACKAGE__->has_a('beer',    'BeerDB::Beer');

	package BeerDB::Drinker;
	__PACKAGE__->has_many('pints', 'BeerDB::Pint');
	
	
	# NOTE NEED to do mapping 
	
	# Order a round -- multiple select of all pints if class method
	my $sel = BeerDB::Drinker->to_field('pints', 'select') #  
	
	# Take one down pass it around 
	my $choice = $Drunk->to_field('pints', 'select');  # Choose from what we already have 
    

package Job;

__PACKAGE__->has_a('employer' => 'Employer');
__PACKAGE__->has_a('contact'  => 'Contact')

package Contact;

__PACKAGE__->has_a('employer_also' => 'Employer');
__PACKAGE__->has_many('jobs'  => 'Job',
        { join => { employer => 'employer_also' },
          constraint => { 'finshed' => 0  },
          order_by   => "created ASC",
        }
);

package Employer;

__PACKAGE__->has_many('jobs'  => 'Job',);
__PACKAGE__->has_many('contacts'  => 'Contact',
            order_by => 'name DESC',
);


  # Below gives select boxes with the multiple attribute.
  my $select_jobs_for_new_contact =
    Contact->to_field('jobs', 'select'); # Uses constraint and order by

  my $edit_jobs_for_existing_contact =
    $contact->to_field('jobs', 'select');



	# Random uses 
	


=head1 DESCRIPTION

This module helps to generate HTML forms for creating new database rows
or editing existing rows. It maps column names in a database table to
HTML form elements which fit the schema. Large text fields are turned
into textareas, and fields with a has-a relationship to other
C<Class::DBI> tables are turned into select drop-downs populated with
objects from the joined class.

=head1 METHODS

The module is a mix-in which adds two additional methods to your
C<Class::DBI>-derived class. 




=head2 unselect_element

Unselects all options in a HTML::Element of type select.
It does nothing if element is not a select element.

=cut

sub unselect_element {
	my ($self, $el) = @_;
	#unless (ref $el eq 'HTML::Element') { 
	#$self->_croak ('Need an HTML::Element to unselect. You gave a ' . Dumper($el)); }
	if ($el->tag eq 'select') {
		foreach my $opt ($el->content_list) {
			$opt->attr('selected', undef) if $opt->attr('selected');
		}
	}
}


=head2 a_select_box

  Returns a HTML::Element representing a select box, based on the arguments

=cut

# make a select box from args
sub a_select_box {
	my ($self, $name, $vals, $selected_val, $contents) = @_;
	die "Usage: Need a name and array ref of values to make a select boxes" unless ($name && $vals);
	$selected_val ||= "";
	$contents ||= $vals ;

	my $a = HTML::Element->new('select', 'name' => $name);
	my $i = 0;
	my $c;
	foreach my $v ( @$vals ) {
		my $opt = HTML::Element->new('option', 'value' => $v);
		$opt->attr('selected' => 'selected') if $v eq $selected_val;
	 	$c = $contents->[$i++] || $v;
		$opt->push_content($c);
		$a->push_content($opt);
	}
	$a;
}



=head2 to_cgi

This returns a hash mapping all the column names of the class to
HTML::Element objects representing form widgets.

pjs -- added a columns list argument to specify which columns to make
inputs for.

=cut

sub to_cgi {
	my ($class, @columns) = @_; # pjs -- added columns arg
	@columns = $class->columns unless (@columns);
	map { $_ => $class->to_field($_) } @columns;
}


=head2 to_field($field [, $how])

This maps an individual column to a form element. The C<how> argument
can be used to force the field type into one of C<textfield>, C<textarea>
or C<select>; you can use this is you want to avoid the automatic detection
of has-a relationships.

# pjs 
   -- added support for enum and bool.   Note for enum and bool you need 
      a better column_type method than the Plugin::Type ' s as it won't work 
      if you are using MySQL. I have not tried others.  
      See those method's docs below.
   -- Foreign inputs for might_have, must_have, has_own, and has_many(i think).
   -- Really any relationship except has_a and is_a as has_a gets a select box
      and is_a are not considered foreign. 
   -- Note a good column_type sub can be 
      used to get the correct type for is_a columns.
   -- More efficient _to_select -- no object creation.
   -- Attempts to set default value in field for you using a "column_default" 
      method you write yourself or your CDBI driver like mysql writes.
   -- _to_hidden 

=cut

sub to_field {
	my ($self, $field, @args) = @_;
    my $how = shift @args unless ref $args[0];  

    my $args = shift @args;  # argument hash ref  
	use Data::Dumper;

	return 	$self->_field_from_how($field, $how, $args)   || 
	       	$self->_field_from_relationship($field, $args) ||
		   	$self->_field_from_column($field, $args)  ||
	  		$self->_to_textfield($field, $args);
}

=head2 _field_from_how($field, $how,$args)

Returns an input element based the "how" parameter or nothing at all.
Override at will. 

=cut

sub _field_from_how {
	my ($self, $field, $how, $args) = @_;
	$args ||= '';
#	warn "field is $field. how is $how. args are $args";
	no strict 'refs';
	my $meth = $how ? "_to_$how" : '' ;
#	warn "Meth is $meth. field is $field";
	return $self->$meth($field, $args) if $meth and $self->can($meth);
	return;
}

=head2 _field_from_relationship($field, $args)

Returns an input based on the relationship associated with the field or nothing.
Override at will.

For has_a it will give select box

=cut

sub _field_from_relationship {
	my ($self, $field, $args) = @_;
	my $rel_meta = $self->related_meta('r',$field) || return; 
	my $rel_name = $rel_meta->{name};
	#my $meta = $self->meta_info;
	#grep{ defined $meta->{$_}{$field} } keys %$meta;
	my $fclass = $rel_meta->foreign_class;
    $args->{class} = $fclass;
	my $fclass_is_cdbi = $fclass ? $fclass->isa('Class::DBI') : 0;

	# maybe has_a select 
#	warn "Dumper of relmeta. " . Dumper($rel_meta);
	if ($rel_meta->{name} eq 'has_a' and $fclass_is_cdbi) {
	    # This condictions allows for trumping of the has_a args
		if  (not $rel_meta->{args}{no_select} and not $args->{no_select}) 
		{
    		return  $self->_to_select($field, $args);
		}
		return;
	}

		
	
	#NOOO!  maybe select from has_many 
#	if ($rel_type eq 'has_many' and ref $self) {
#		$args->{items} ||= [$self->$field];
#		# arg name || fclass pk name || field
#		if (not $args->{name}) {
#			$args->{name} =  eval{$fclass->primary_column->name} || $field; 
#		}
#    	return  $self->_to_select($field, $args);
#	}
#
	# maybe foreign inputs 
	my %local_cols = map { $_ => 1 } $self->columns; # includes is_a cols
	if ($fclass_is_cdbi and (not $local_cols{$field} or $rel_name eq 'has_own'))
	{
		$args->{related_meta} = $rel_meta; # suspect faster to set these args 
		return $self->_to_foreign_inputs($field, $args);
	}
	return;
}

=head2 _field_from_column($field, $args)

Returns an input based on the column's characteristics, namely type, or nothing.
Override at will.

=cut

sub _field_from_column {
	my ($self, $field, $args) = @_;
	my $class = ref $self || $self;
	# Get column type	
    unless ($args->{column_type}) { 
    	if ($class->can('column_type')) {
			$args->{column_type} = $class->column_type($field);
		}	
		else {
    		# Right, have some of this
    		eval "package $class; Class::DBI::Plugin::Type->import()";
    		$args->{column_type} = $class->column_type($field);
		}
    }
    my $type = $args->{column_type};

	return $self->_to_textfield($field)
		if $type  and $type =~ /(VAR)?CHAR/i;  #common type
	return $self->_to_textarea($field, $args)
		if $type and $type =~ /^(TEXT|BLOB)$/i;
	return $self->_to_enum_select($field, $args)  
		if $type and  $type =~ /^ENUM\((.*?)\)$/i; 
	return $self->_to_bool_select($field, $args)
		if $type and  $type =~ /^BOOL/i; 
	return $self->_to_readonly($field, $args)
	    if $type and $type =~ /^readonly$/i;
	return;
}


sub _to_textarea {
	my ($self, $col, $args) = @_;
 	# pjs added default	
    $args ||= {};
    my $val =  $args->{value}; 
    
    unless (defined $val) {
        if (ref $self) {
			$val = $self->$col; 
		}
		else { 
			$val = eval {$self->column_default($col);}; 
	    	$val = '' unless defined $val;  
		}
	}
    my ($rows, $cols) = _box($val);
    $rows = $args->{rows} if $args->{rows};
    $cols = $args->{cols} if $args->{cols};;
    my $name = $args->{name} || $col; 
	my $a =
		HTML::Element->new("textarea", name => $name, rows => $rows, cols => $cols);
	$a->push_content($val);
	$OLD_STYLE && return $a->as_HTML;
	$a;
}

sub _to_textfield {
    my ($self, $col, $args ) = @_;
    $args ||= {};
    my $val = $args->{value}; 
    my $name = $args->{name} || $col; 

    unless (defined $val) {
        if (ref $self) {
            # Case where column inflates.
            # Input would get stringification which could be not good.
            #  as in the case of Time::Piece objects
            $val = $self->$col;
            if (ref $val) {
				if (my $meta = $self->related_meta('',$col)) {
#				warn "Meta for $col";
               		if (my $code = $meta->{args}{deflate4edit} ) {
                    	$val  = ref $code ? &$code($val) : $val->$code;
					}
					elsif ( $val->isa('Class::DBI') ) {
					    $val  = $val->id;
					}
					else { 
						warn "No deflate4edit code defined for $val of type " . 
					     ref $val . ". Using the stringified value in textfield..";
					}
               	}
				else {
					warn "No meta for $col but ref $val.\n";
					$val  = $val->id if $val->isa("Class::DBI"); 
               }
        	}
			
        }
       	else {
         	$val = eval {$self->column_default($col);};
           	$val = '' unless defined $val;
        }
    }
    my $a = HTML::Element->new("input", type => "text", name => $name);
    $a->attr("value" => $val);
    $OLD_STYLE && return $a->as_HTML;
    $a;
}


# Too expensive version -- TODO
#sub _to_select {
#	my ($self, $col, $hint) = @_;
#	my $fclass = $hint || $self->__hasa_rels->{$col}->[0];
#	my @objs        = $fclass->retrieve_all;
#	my $a           = HTML::Element->new("select", name => $col);
#	for (@objs) {
#		my $sel = HTML::Element->new("option", value => $_->id);
#		$sel->attr("selected" => "selected")
#			if ref $self
#			and eval { $_->id eq $self->$col->id };
#		$sel->push_content($_->stringify_self);
#		$a->push_content($sel);
#	}
#	$OLD_STYLE && return $a->as_HTML;
#	$a;
#}



# pjs 
# -- Rewrote this to be efficient -- no object creation. 
# -- Added option for CDBI classes to specify a limiting clause
# via "has_a_select_limit". 
# -- Added selected argument to set a selected 

=head2 recognized arguments
 
  selected => $object|$id,
  name     => $name,
  value    => $value,
  where    => SQL 'WHERE' clause,
  order_by => SQL 'ORDER BY' clause,
  limit    => SQL 'LIMIT' clause,
  items    => [ @items_of_same_type_to_select_from ],
  class => $class_we_are_selecting_from
  stringify => $stringify_coderef|$method_name
  
  


# select box requirements
# 1. a select box for objecs of a has_a related class -- DONE 
=head2  1. a select box out of a has_a or has_many related class.
  # For has_a the default behavior is to make a select box of every element in 
  # related class and you choose one. 
  #Or explicitly you can create one and pass options like where and order
  BeerDB::Beer->to_field('brewery','select', {where => "location = 'Germany'");
  
  # For has_many the default is to get a multiple select box with all objects.
  # If called as an object method, the objects existing ones will be selected. 
  Brewery::BeerDB->to_field('beers','select', {where => "rating > 5"}); 
  

=head2  2. a select box for objects of arbitrary class -- say BeerDB::Beer for fun. 
  # general 
  BeerDB::Beer->to_field('', 'select', $options)

  BeerDB::Beer->to_field('', 'select'); # Select box of all the rows in class
                                  # with PK as ID, $Class->to_field() same.
  BeerDB::Beer->to_field('','select',{ where => "rating > 3 AND class like 'Ale'", order_by => 'rating DESC, beer_id ASC' , limit => 10});
  # specify exact where clause 

=head2 3. If you already have a list of objects to select from  -- 

  BeerDB:;Beer->to_field($col, 'select' , {items => $objects});

# 3. a select box for arbitrary set of objects 
 # Pass array ref of objects as first arg rather than field 
 $any_class_or_obj->to_field([BeerDB::Beer->search(favorite => 1)], 'select',);
 

=cut

sub _to_select {
    my ($self, $col, $args) = @_;
    $args ||= {};
# Do we have items already ? Go no further. 
    if ($args->{items}) {  
       	my $a = $self->_select_guts($col,  $args);
    	$OLD_STYLE && return $a->as_HTML;
		return $a;
	}

# Else what are we making a select box out of ?  
	# No Column parameter --  means making a select box of args->class or self 
    # Using all rows from class's table
    if (not $col) { 
        warn "No col. $self";
		unless ($args->{class}) {
        	$args->{class} = ref $self || $self;
			# object selected if called with one
            $args->{selected} = { $self->id => 1} 
				if not $args->{selected} and ref $self;
		}
        $col = $args->{class}->primary_column;
    }
    # Related Class maybe ? 
    elsif (my $rel_meta =  $self->related_meta('r:)', $col) ) {
        $args->{class} = $rel_meta->{foreign_class};
        # related objects pre selected if object
				
		# "Has many" -- Issues:
		# 1) want to select one from list if self is an object
		# Thats about all we can do really, 
		# 2) except for mapping which is TODO and  would 
		# do something like add to and take away from list of permissions for
		# example.

		# Hasmany select one from list if ref self
		if ($rel_meta->{name} =~ /has_many/i and ref $self) {
			$args->{items} = [ $self->$col ];
			my $a = $self->_select_guts($col,  $args);
		    $OLD_STYLE && return $a->as_HTML;
		    return $a;
		}
		else {
			$args->{selected} ||= [ $self->$col ] if  ref $self; 
#			warn "selected is " . Dumper($args->{selected});
			my $c = $rel_meta->{args}{constraint} || {};
			my $j = $rel_meta->{args}{join} || {};
			my @join ; 
			if (ref $self) {
				@join   =  map { $_ ." = ". $self->_attr($_) } keys %$j; 
			}
			my @constr= map { "$_ = '$c->{$_}'"} keys %$c; 
			$args->{where}    ||= join (' AND ', (@join, @constr));
			$args->{order_by} ||= $rel_meta->{args}{order_by};
			$args->{limit}    ||= $rel_meta->{args}{limit};
		}
			
    }
    # We could say :Col is name and we are selecting  out of class arg.
	# DIE for now
	else {
		#$args->{name} = $col;
		die "Usage _to_select. $col not related to any class to select from. ";
		
    }
		
    # Set arguments 
	if ( $self->can('column_nullable') ) { 
		$args->{nullable} ||= $self->column_nullable($col);
	}

	# Get items to select from
    $args->{items} = _select_items($args);
#    warn "Items selecting from are " . Dumper($args->{items});
#use Data::Dumper;
#warn "Just got items. They are  " . Dumper($args->{items});

	# Make select HTML element
	$a = $self->_select_guts($col, $args);

	# Return 
    $OLD_STYLE && return $a->as_HTML;
    $a;

}


##############
# Function # 
# #############
# returns the intersection of list refs a and b
sub _list_intersect {
	my ($a, $b) = @_;
	my %isect; my %union;
    foreach my $e (@$a, @$b) { $union{$e}++ && $isect{$e}++ }
	return  %isect;
}
############
# FUNCTION #
############
# Get Items 
sub _select_items { 
	my $args = shift;
	my $fclass = $args->{class};
    my @disp_cols;
    @disp_cols = $fclass->columns('SelectBox');
    @disp_cols = $fclass->columns('Stringify')unless @disp_cols;
    @disp_cols = $fclass->_essential unless @disp_cols;
	unshift @disp_cols,  $fclass->columns('Primary');
	#my %isect = _list_intersect(\@pks, \@disp_cols);
	#foreach (@pks) { push @sel_cols, $_ unless $isect{$_}; } 
    #push @sel_cols, @disp_cols;		


    my $sql = "SELECT " . join( ', ', @disp_cols) . 
	          " FROM " . $fclass->table;

	$sql .=	" WHERE " . $args->{where}   if $args->{where};
	$sql .= " ORDER BY " . $args->{order_by} if $args->{order_by};
	$sql .= " LIMIT " . $args->{limit} if $args->{limit};
#warn "_select_items sql is : $sql";

	return $fclass->db_Main->selectall_arrayref($sql);

}


# Makes a readonly input box out of column's value
# No args makes object to readonly
sub _to_readonly {
    my ($self, $col, $val) = @_;
    if (! $col) { # object to readonly
        $val = $self->id;
        $col = $self->primary_column;
    }
    unless (defined $val) {
        $self->_croak("Cannot get value in _to_readonly .")
            unless ref $self;
        $val = $self->$col;
    }
    my $a = HTML::Element->new('input', 'type' => 'text', readonly => '1',
        'name' => $col, 'value'=>$val);
$OLD_STYLE && return $a->as_HTML;
    $a;
}


=head2 _to_enum_select

$sel_box = $self->_to_enum_select($column, "ENUM('Val1','Val2','Val3')");

Returns an enum select box given a column name and an enum string.
NOTE: The Plugin::Type does not return an enum string for mysql enum columns.
This will not work unless you write your own column_type method in your model.

=cut

sub _to_enum_select {
    my ($self, $col, $type) = @_;
    $type =~ /ENUM\((.*?)\)/i;
    (my $enum = $1) =~ s/'//g;
    my @enum_vals = split /\s*,\s*/, $enum;

    # determine which is pre selected --
    # if obj, the value is , otherwise use column_default which is the first
    # value in the enum list unless it has been overridden
    my $selected = eval { $self->$col  };
    $selected = eval{$self->column_default($col)} unless defined $selected;
    $selected = $enum_vals[0]               unless defined $selected;


    my $a = HTML::Element->new("select", name => $col);
    for ( @enum_vals ) {
        my $sel = HTML::Element->new("option", value => $_);
        $sel->attr("selected" => "selected") if $_ eq $selected ;
        $sel->push_content($_);
        $a->push_content($sel);
    }
    $OLD_STYLE && return $a->as_HTML;
    $a;
}


=head2 _to_bool_select

  my $sel = $self->_to_bool_select($column, $bool_string);

This  makes select input for boolean column.  You can provide a
bool string of form: Bool('zero','one') and those are used for option
content. Onthervise No and Yes are used.
TODO -- test without bool string.

=cut

sub _to_bool_select {
    my ($self, $col, $type) = @_;
	my @bool_text = ('No', 'Yes');	
	if ($type =~ /BOOL\((.+?)\)/i) {
		(my $bool = $1) =~ s/'//g;
		@bool_text = split /,/, $bool;
	}
	my $one= ref $self ? eval {$self->$col;} : $self->column_default($col);
    my $a = HTML::Element->new("select", name => $col);
    my ($opt0, $opt1) = ( HTML::Element->new("option", value => 0),
						  HTML::Element->new("option", value => 1) ); 
    $opt0->attr("selected" => "selected") if not $one; 
    $opt0->push_content($bool_text[0]); 
    $opt1->attr("selected" => "selected") if $one; 
    $opt1->push_content($bool_text[1]); 
    $a->push_content($opt0, $opt1);
    $OLD_STYLE && return $a->as_HTML;
    $a;
}


=head2 _to_hidden($col, $args)

This makes a hidden html element. Give it a name and value or if name is
a ref it will use the PK name and value of the object.

=cut

sub _to_hidden {
    my ($self, $name, $val) = @_;
    my $args = {};
    my $obj;
    if (ref $name and $name->isa("Class::DBI")) {
       $obj = $name;
       $name= ($obj->primary_columns)[0]->name;
    }
    if (ref $val) {
		$args = $val;
        $val = $args->{value};
        $name = $args->{name} if $args->{name};
    }
    elsif (not $name ) { # hidding object caller
        $self->_croak("No object available in _to_hidden") unless ref $self;
        $name = ($self->primary_column)[0]->name;
        $val  = $self->id;
    }
    return HTML::Element->new('input', 'type' => 'hidden',
                              'name' => $name, 'value'=>$val
    );
}

=head2 _to_link_hidden($col, $args) 

Makes a link with a hidden input with the id of $obj as the value and name.
Name defaults to the objects primary key. The object defaults to self.

=cut

sub _to_link_hidden {
    my ($self, $accessor, $args) = @_;
    my $r = $args->{r} || '';
    my $url = $args->{url} || '';
   use Data::Dumper;
#   warn "$self Args are " . Dumper($args);
    $self->_croak("_to_link_hidden called without Maypole Request object (\$r) and url. Need one or other.")
        unless $r;
    my ($obj, $name);
    if (ref $self) { # hidding linking self
         $obj  = $self;
         $name = $args->{name} || $obj->primary_column->name;
    }
    else {           # hiding linking related object with id in args
        $obj  = $self->related_class($r, $accessor)->retrieve($args->{id});
        $name = $args->{name} || $obj->primary_column->name; # TODO make use meta data
    }
    $self->_croak("_to_link_hidden has no object") unless ref $obj;
    my $href =  $url || $r->config->{uri_base} . "/". $obj->table."/view/".$obj->id;
    my $a = HTML::Element->new('a', 'href' => $href);
    $a->push_content("$obj");
    $a->push_content($self->_to_hidden($name, $obj->id));
	$OLD_STYLE && return $a->as_HTML;
    $a;
}



=head2 _to_foreign_inputs

$html_els = $class_or_obj->_to_foreign_inputs($accssr, [$fields, $accssr_meta]);

Get inputs for the accessor's class.  Pass an array ref of fields to get
inputs for only those fields. Otherwise display_columns or all columns is used. 
If you have the meta info handy for the accessor you can pass that too.

TODO make AsForm know more about the request like what action we are doing
so it can use edit columns or search_columns

NOTE , this names the foreign inputs is a particular way so they can be
processed with a general routine and so there are not name clashes.

args -
related_meta -- if you have this, great, othervise it will determine or die
columns  -- list of columns to make inputs for 

=cut

sub _to_foreign_inputs {
	my ($self, $accssr, $args) = @_;
	my $rel_meta = $args->{related_meta} || $self->related_meta('r',$accssr); 
	my $fields 		= $args->{columns};
	if (!$rel_meta) {
		$self->_croak( "No relationship for accessor $accssr");
	}

	my $rel_type = $rel_meta->{name};
	my $classORobj = ref $self && ref $self->$accssr ? $self->$accssr : $rel_meta->{foreign_class};
	
	unless ($fields) { 	
		$fields = $classORobj->can('display_columns') ? 
			[$classORobj->display_columns] : [$classORobj->columns];
	}
	
	# Ignore our fkey in them to  prevent infinite recursion 
	my $me 	        = eval {$rel_meta->{args}{foreign_column}} || '';  
	my $constrained = $rel_meta->{args}{constraint}; 
	my %inputs;
	foreach ( @$fields ) {
		next if $constrained->{$_} || ($_ eq $me); # don't display constrained
		$inputs{$_} =  $classORobj->to_field($_);
	}

	# Make hidden inputs for constrained columns unless we are editing object
	# TODO -- is this right thing to do?
	unless (ref $classORobj || $args->{no_hidden_constraints}) {
		$inputs{$_} = $classORobj->_to_hidden($_, $constrained->{$_}) 
			foreach ( keys %$constrained );  
	}
	$self->_rename_foreign_input($accssr, \%inputs);
	return \%inputs;
}


=head2 _hash_selected

Method to make sense out of the "selected" argument which can be in a number
of formats perhaps.  It returns a hashref with the the values of options to be
as the keys. 

Below handles these formats for the "selected" slot in the arguments hash:
  Object (with id method)
  Scalar (assumes it is value)
  Array ref *OF* objects, arrays of data (0 elmnt used), hashes of data
    (id key used), and simple scalars.
    

=cut 
 
############
# FUNCTION #
############
sub _hash_selected {
	my ($args) = shift;
	my $selected = $args->{selected};
    return $selected unless $selected and ref $selected ne 'HASH'; 
	my $type = ref $selected;
	# Single Object 
    if ($type and $type ne 'ARRAY') {
       return  {$selected->id => 1};
    }
    # Single Scalar id 
	elsif (not $type) {
		return { $selected => 1}; 
	}

	# Array of objs, arrays, hashes, or just scalalrs. 
	elsif ($type eq 'ARRAY') {
		my %hashed;
		my $ltype = ref $selected->[0];
		# Objects
		if ($ltype and $ltype ne 'ARRAY')  {
			%hashed = map { $_->id  => 1 } @$selected;
       	}
		# Arrays of data with id first 
	    elsif ($ltype and $ltype eq 'ARRAY') {
			%hashed = map { $_->[0]  => 1 } @$selected; 
		}
		# Hashes using pk or id key
		elsif ($ltype and $ltype eq 'HASH') {
			my $pk = $args->{class}->primary_column || 'id';
			%hashed = map { $_->{$pk}  => 1 } @$selected; 
		}
		# Just Scalars
        else { 
			%hashed = map { $_  => 1 } @$selected; 
		}
		return \%hashed;
	}
	else { warn "AsForm Could not hash the selected argument: $selected"; }
}


=head2 _select_guts

Internal api  method to make the actual select box form elements.

3 types of lists making for -- 
  Array of CDBI objects.
  Array of scalars , 
  Array or  Array refs with cols from class.

=cut


sub _select_guts {
    my ($self, $col, $args) = @_; #$nullable, $selected_id, $values) = @_;

    $args->{stringify} ||=  'stringify_selectbox';
    $args->{selected} = _hash_selected($args);
	my $name = $args->{name} || $col;
    my $a = HTML::Element->new('select', name => $name);
	$a->attr( %{$args->{attr}} ) if $args->{attr};
    
    if ($args->{nullable}) {
		my $null_element = HTML::Element->new('option');
        $null_element->attr(selected => 'selected')
	    	if ($args->{selected}{'null'});
		$null_element->push_content('-- choose or type --');
        $a->push_content($null_element);
    }

    my $items = $args->{items};
    my $proto = $items->[0];
    my $type  = ref $proto || '';

    # Objects 
    if (not $type) {
		$a->push_content($self->_options_from_scalars($items, $args));
	}
	elsif($type !~ /ARRAY|HASH/i) {
		# make select  of objects
		$a->push_content($self->_options_from_objects($items, $args));
  	}
    elsif ($type =~ /ARRAY/i) {
		$a->push_content($self->_options_from_arrays($items, $args));
    }
    elsif ($type =~ /HASH/i) { 
		$a->push_content($self->_options_from_hashes($items, $args));
    }
    else { 
		die "You passed a weird type of data structure to me. Here it is: $type";
    }

    return $a;
}

		
  
  



=head2 _options_from_objects ( $objects, $args);

Private method to makes a options out of  objects. It attempts to call each
objects stringify method specified in $args->{stringify} as the content. Otherwise the default stringification prevails.

=cut
sub _options_from_objects {
    my ($self, $items, $args) = @_;
	my $selected = $args->{selected} || {};
	my $stringify = $args->{stringify} || '';
    my @res;
	for (@$items) {
		my $opt = HTML::Element->new("option", value => $_->id);
		$opt->attr(selected => "selected") if $selected->{$_->id}; 
		my $content = $stringify ? $_->$stringify : "$_";
		$opt->push_content($content);
		push @res, $opt; 
	}
    return @res;
}

sub _options_from_arrays {
    my ($self, $items, $args) = @_;
	my $selected = $args->{selected} || {};
    my @res;
	my $class = $args->{class} || '';
	my $stringify = $args->{stringify} || '';
	for my $item (@$items) {
	    my @pks;
	    push @pks, shift @$item foreach $class->columns('Primary');
		my $id = $pks[0] + 0; # In case zerofill is on .
		my $opt = HTML::Element->new("option", value => $id );
		$opt->attr(selected => "selected") if $selected->{$id};
		
		my $content = ($class and $stringify and $class->can($stringify)) ? 
		              $class->$stringify($_) : 
			          join( '/', map { $_ if $_; }@{$item} );
		$opt->push_content( $content );
        push @res, $opt; 
    }
    return @res;
}

sub _options_from_scalars {
    my ($self, $items, $args) = @_;
	my $selected = $args->{selected} || {};
    my @res;
	for (@$items) {
		my $opt = HTML::Element->new("option", value => $_ );
		#$opt->attr(selected => "selected") if $selected =~/^$id$/;
		$opt->attr(selected => "selected") if $selected->{$_};
		$opt->push_content( $_ );
        push @res, $opt; 
    }
    return @res;
}

sub _options_from_hashes {
  my ($self, $items, $args) = @_;
  my $selected = $args->{selected} || {};
  my $pk = eval {$args->{class}->primary_column} || 'id';
  my $fclass = $args->{class} || '';
  my $stringify = $args->{stringify} || '';
  my @res;
  for (@$items) {
    my $val = $_->{$pk};
    my $opt = HTML::Element->new("option", value => $val );
    $opt->attr(selected => "selected") if $selected->{$val};
    my $content = ($fclass && $stringify && $fclass->can($stringify)) ? 
      $fclass->$stringify($_) : 
	join(' ', @$_);
    $opt->push_content( $content );
    push (@res, $opt); 
  }
  return @res;
}
	
# 
# checkboxes: if no data in hand (ie called as class method), replace
# with a radio button, in order to allow this field to be left
# unspecified in search / add forms.
# 
# Not tested
# TODO  --  make this general checkboxse
# 
#
sub _to_checkbox {
    my ($self, $col, $args) = @_;
    my $nullable = eval {self->column_nullable($col)} || 0; 
    
    return $self->_to_radio($col) if !ref($self) || $nullable;
    my $value = $self->$col;
    my $a = HTML::Element->new("input", type=> "checkbox", name => $col);
    $a->attr("checked" => 'true') if $value eq 'Y';
    return $a;
}


# TODO  -- make this general radio butons
#
sub _to_radio {
    my ($self, $col) = @_;
    my $value = ref $self && $self->$col || '';
    my $nullable = eval {self->column_nullable($col)} || 0; 
    my $a = HTML::Element->new("span");
    my $ry = HTML::Element->new("input", type=> "radio", name=>$col, value=>'Y' );
    my $rn = HTML::Element->new("input", type=> "radio", name=>$col, value=>'N' );
    my $ru = HTML::Element->new("input", type=> "radio", name=>$col, value=>'' ) if $nullable;
    $ry->push_content('Yes'); $rn->push_content('No');
    $ru->push_content('n/a') if $nullable;
    if ($value eq 'Y') { $ry->attr("checked" => 'true') }
    elsif ($value eq 'N') { $rn->attr("checked" => 'true') }
    elsif ($nullable) { $ru->attr("checked" => 'true') }
    $a->push_content($ry, $rn);
    $a->push_content($ru) if $nullable;
    return $a;
}



############################ HELPER METHODS ######################
##################################################################

=head2 _rename_foreign_input

_rename_foreign_input($html_el_or_hash_of_them); # changes made by reference

Recursively renames the foreign inputs made by _to_foreign_inputs so they 
can be processed generically.  The format is "accessor__AsForeign_colname". 

So if an Employee is a Person who has_own  Address and you call 

  Employee->to_field("person")  
  
then you will get inputs for the Person as well as their Address (by default,
override _field_from_relationship to change logic) named like this: 

  person__AsForeign__address__AsForeign__street
  person__AsForeign__address__AsForeign__city
  person__AsForeign__address__AsForeign__state  
  person__AsForeign__address__AsForeign__zip  

And the processor would know to create this address, put the address id in
person->address data slot, create the person and put the person id in the employee->person data slot and then create the employee with that data.

Overriede make_element_foreign to change how you want a foreign param labeled.

=head2 make_element_foreign

  $class->make_element_foreign($accessor, $element);
  
Makes an HTML::Element type object foreign elemen representing the 
class's accessor.  (IE this in an input element for $class->accessor :) )

=cut

sub make_element_foreign {
	my ($self, $accssr, $element)  = @_;
	$element->attr( name => $accssr . "__AsForeign__" . $element->attr('name'));
}



sub _rename_foreign_input {
	my ($self, $accssr, $element) = @_;
	if ( ref $element ne 'HASH' ) {
	#	my $new_name = $accssr . "__AsForeign__" . $input->attr('name');
		$self->make_element_foreign($accssr, $element);
	}
	else {
		$self->_rename_foreign_input($accssr, $element->{$_}) 
			foreach (keys %$element);
	}
}
=head2 _box($value) 

This functions computes the dimensions of a textarea based on the value 
or the defaults.

=cut

our ($min_rows, $max_rows, $min_cols, $max_cols) = (2 => 50, 20 => 100);
sub _box
{
    my $text = shift;
    if ($text) {
	my @rows = split /^/, $text;
	my $cols = $min_cols;
	my $chars = 0;
	for (@rows) {
	    my $len = length $_;
	    $chars += $len;
	    $cols = $len if $len > $cols;
	    $cols = $max_cols if $cols > $max_cols;
	}
	my $rows = @rows;
	$rows = int($chars/$cols) + 1 if $chars/$cols > $rows;
	$rows = $min_rows if $rows < $min_rows;
	$rows = $max_rows if $rows > $max_rows;
	($rows, $cols)
    }
    else { ($min_rows, $min_cols) }
}


1;


=head1 CHANGES

=head1 MAINTAINER 

Maypole Developers

=head1 ORIGINAL AUTHOR

Peter Speltz, Aaron Trevena 

=head1 TODO

  Documenting 
  Testing - lots
  chekbox generalization
  radio generalization
  select work
  Make link_hidden use standard make_url stuff when it gets in Maypole
  How do you tell AF --" I want a has_many select box for this every time so,
     when you call "to_field($this_hasmany)" you get a select box

=head1 BUGS and QUERIES

Please direct all correspondence regarding this module to:
 Maypole list. 

=head1 COPYRIGHT AND LICENSE

Copyright 2003-2004 by Simon Cozens / Tony Bowden

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.

=head1 SEE ALSO

L<Class::DBI>, L<Class::DBI::FromCGI>, L<HTML::Element>.

=cut




