package DBIx::Class::WebForm; use strict; use warnings; use HTML::Element; our $VERSION = '0.01'; =head1 NAME DBIx::Class::WebForm - CRUD Methods For DBIx::Clas =head1 SYNOPSIS use base 'DBIx::Class::WebForm'; my $results = Data::FormValidator->check( ... ); my $film = Film->retrieve('Fahrenheit 911'); $film->update_from_form($results); my $new_film = Film->create_from_form($results); =head1 DESCRIPTION CRUD Methods For DBIx::Class. =head1 METHODS =over 4 =item $class->create_from_form($form) =cut sub create_from_form { my $class = shift; die "create_from_form can only be called as a class method" if ref $class; __PACKAGE__->_run_create( $class, @_ ); } =item $self->update_from_form($form) =cut sub update_from_form { my $self = shift; die "update_from_form cannot be called as a class method" unless ref $self; __PACKAGE__->_run_update( $self, @_ ); } sub _run_create { my ( $me, $class, $results ) = @_; my $them = bless {}, $class; my $cols = {}; foreach my $col ( $them->columns ) { $cols->{$col} = $results->valid($col); } return $class->create($cols); } sub _run_update { my ( $me, $them, $results ) = @_; my %pk; $pk{$_} = 1 for $them->primary_columns; foreach my $col ( keys %{ $results->valid } ) { if ( $them->can($col) ) { next if $pk{$col}; my $val = $results->valid($col); $them->$col($val); } } $them->update; return 1; } =item $class->to_cgi =cut sub to_cgi { my $class = shift; map { $_ => $class->to_field($_) } $class->columns; } =item $self->to_field( $field, $how ) =cut sub to_field { my ( $self, $field, $how ) = @_; my $class = ref $self || $self; if ( $how and $how =~ /^(text(area|field)|select)$/ ) { no strict 'refs'; my $meth = "_to_$how"; return $class->$meth($field); } my $hasa = $class->_relationships->{$field}; return $self->_to_select($field) if defined $hasa and $class->resolve_class( $hasa->{class} )->isa("DBIx::Class"); my $type = $class->column_type($field); return $self->_to_textarea($field) if $type and $type =~ /^(TEXT|BLOB)$/i; return $self->_to_textfield($field); } sub _to_textarea { my ( $self, $col ) = @_; my $a = HTML::Element->new( "textarea", name => $col, rows => "3", cols => "22" ); if ( ref $self ) { $a->push_content( $self->$col ) } $a; } sub _to_textfield { my ( $self, $col ) = @_; my $value = ref $self && $self->$col; my $a = HTML::Element->new( "input", type => "text", name => $col ); $a->attr( "value" => $value ) if $value; $a; } sub _to_select { my ( $self, $col, $hint ) = @_; my $has_a_class = $hint || $self->resolve_class( $self->_relationships->{$col}->{class} ); my @objs = $has_a_class->search; 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( $_ . '' ); $a->push_content($sel); } $a; } =item $class->column_type($col) =cut sub column_type { my ( $class, $col ) = @_; return $class->_columns->{$col}->{column_type}; } =back =head1 AUTHOR Sebastian Riedel, C<sri@oook.de> =head1 LICENSE This library is free software, you can redistribute it and/or modify it under the same terms as Perl itself. =cut 1;