[Catalyst-commits] r7485 - in CatalystX-CRUD/CatalystX-CRUD: .
trunk trunk/lib trunk/lib/CatalystX trunk/lib/CatalystX/CRUD
trunk/lib/CatalystX/CRUD/Iterator trunk/lib/CatalystX/CRUD/Model
trunk/lib/CatalystX/CRUD/Object trunk/t trunk/t/lib
trunk/t/lib/MyApp trunk/t/lib/MyApp/Controller
trunk/t/lib/MyApp/Model
karpet at dev.catalyst.perl.org
karpet at dev.catalyst.perl.org
Tue Mar 11 17:19:05 GMT 2008
Author: karpet
Date: 2008-03-11 17:19:03 +0000 (Tue, 11 Mar 2008)
New Revision: 7485
Added:
CatalystX-CRUD/CatalystX-CRUD/branches/
CatalystX-CRUD/CatalystX-CRUD/trunk/
CatalystX-CRUD/CatalystX-CRUD/trunk/Changes
CatalystX-CRUD/CatalystX-CRUD/trunk/MANIFEST
CatalystX-CRUD/CatalystX-CRUD/trunk/Makefile.PL
CatalystX-CRUD/CatalystX-CRUD/trunk/README
CatalystX-CRUD/CatalystX-CRUD/trunk/lib/
CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/
CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD.pm
CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/
CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Controller.pm
CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Controller/
CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Iterator.pm
CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Iterator/
CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Iterator/File.pm
CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Model.pm
CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Model/
CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Model/File.pm
CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Model/Utils.pm
CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Object.pm
CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Object/
CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Object/File.pm
CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/REST.pm
CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Tutorial.pod
CatalystX-CRUD/CatalystX-CRUD/trunk/t/
CatalystX-CRUD/CatalystX-CRUD/trunk/t/00-load.t
CatalystX-CRUD/CatalystX-CRUD/trunk/t/01-file.t
CatalystX-CRUD/CatalystX-CRUD/trunk/t/boilerplate.t
CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/
CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp.pm
CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp/
CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp/Controller/
CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp/Controller/File.pm
CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp/File.pm
CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp/Model/
CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp/Model/File.pm
CatalystX-CRUD/CatalystX-CRUD/trunk/t/pod-coverage.t
CatalystX-CRUD/CatalystX-CRUD/trunk/t/pod.t
Log:
import from peknet
Added: CatalystX-CRUD/CatalystX-CRUD/trunk/Changes
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/Changes (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/Changes 2008-03-11 17:19:03 UTC (rev 7485)
@@ -0,0 +1,101 @@
+Revision history for CatalystX-CRUD
+
+0.01 3 October 2007
+ First version, released on an unsuspecting world.
+
+0.02 22 October 2007
+ * Fixed Makefile.PL dependencies (added Catalyst::Component::ACCEPT_CONTEXT)
+ * Refactored Controller and Model to abstract a little more, notably
+ added the form_to_object() method in Controller.
+ * New File example implementation of the whole Model/Object/Iterator API.
+
+0.03 22 October 2007
+ * add test for File implementation (and fix the bugs it revealed)
+ * fix AUTOLOAD to ignore DESTROY
+
+0.04 25 October 2007
+ * rework view_on_single_result API in base Controller and tests for same
+
+0.05 1 November 2007
+ * stash query in Controller results for View
+ * do_search() returns if no input
+ * Model reserved params now start with _
+ * some can/AUTOLOAD black magic to make Object/delegate stuff DWIM.
+
+0.06 6 November 2007
+ * clean up temp files from make test [rt# 30425]
+
+0.07 9 November 2007
+ * added count() method to base Controller
+
+0.08 9 November 2007
+ * fix documentation for save() method.
+
+0.09 10 November 2007
+ * fix missing precommit() default sub in Controller.pm
+ * fix AUTOLOAD hackery in Model.pm
+
+
+0.10 12 Nov 2007
+ * simplify Iterator base class to hardcode 'delegate' method name
+
+0.11 14 Nov 2007
+ * fix AUTOLOAD method to report correct object class on error
+
+0.12 17 Nov 2007
+ * fix bug in Controller when determining whether do_search() should search.
+
+0.13 19 Nov 2007
+ * fix bug in Controller when there is only one result in do_search().
+
+0.14 23 Nov 2007
+ * add Tutorial
+ * fix bug (again) in Controller when there is only one result in do_search().
+
+0.15 24 Nov 2007
+ * oops. actually include the tutorial pod in this release.
+
+0.16 04 Dec 2007
+ * fix typo in Tutorial so it shows up in search.cpan.org
+ * fix Controller->do_search() to always include query for view's use,
+ even when there are no results.
+
+0.17 19 Dec 2007
+ * add field_names() method to base Controller class. This is to aid development
+ of CatalystX::CRUD::View implementations.
+
+0.18 20 Dec 2007
+ * added _no_page parameter support to the Model API.
+ * added ::Model::Utils to help with DRY
+
+0.19 21 Dec 2007
+ * added Sort::SQL to Makefile.PL reqs.
+
+0.20 31 Dec 2007
+ * fix view_on_single_result() to check can_write()
+
+0.21 04 Jan 2008
+ * fix black magic can() in Model.pm
+
+0.22 04 Jan 2008
+ * add treat_like_int() support to Model::Utils
+
+0.23 20 Jan 2008
+ * added REST API
+ * added allow_GET_writes Controller config option, to prevent casual GET /save or /delete requests.
+
+0.24 22 Jan 2008
+ * always fetch() in REST->default, to fix bug with no object being set for create()
+ * always uc() the req method for comparison purposes
+ * fix bug when checking the _http_method param to use params() instead of param() and use the first if multiple.
+ * refactor REST to provide backwards compat with Controller for easy @ISA swap (as advertised)
+
+0.25 1 Feb 2008
+ * fix bug to clarify what happens when form_to_object() returns false.
+
+0.26 xxx
+ * fix bug in Iterator to test for !next() rather than !defined(next())
+ * re-set action in ::REST->default so that RPC-style template naming works
+ * use :Path instead of :Private on ::REST->default
+
+
Added: CatalystX-CRUD/CatalystX-CRUD/trunk/MANIFEST
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/MANIFEST (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/MANIFEST 2008-03-11 17:19:03 UTC (rev 7485)
@@ -0,0 +1,24 @@
+Changes
+MANIFEST
+Makefile.PL
+README
+lib/CatalystX/CRUD.pm
+lib/CatalystX/CRUD/Model.pm
+lib/CatalystX/CRUD/Model/Utils.pm
+lib/CatalystX/CRUD/Controller.pm
+lib/CatalystX/CRUD/REST.pm
+lib/CatalystX/CRUD/Object.pm
+lib/CatalystX/CRUD/Iterator.pm
+lib/CatalystX/CRUD/Object/File.pm
+lib/CatalystX/CRUD/Model/File.pm
+lib/CatalystX/CRUD/Iterator/File.pm
+lib/CatalystX/CRUD/Tutorial.pod
+t/00-load.t
+t/boilerplate.t
+t/pod-coverage.t
+t/pod.t
+t/01-file.t
+t/lib/MyApp.pm
+t/lib/MyApp/File.pm
+t/lib/MyApp/Model/File.pm
+t/lib/MyApp/Controller/File.pm
Added: CatalystX-CRUD/CatalystX-CRUD/trunk/Makefile.PL
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/Makefile.PL (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/Makefile.PL 2008-03-11 17:19:03 UTC (rev 7485)
@@ -0,0 +1,26 @@
+use strict;
+use warnings;
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+ NAME => 'CatalystX::CRUD',
+ AUTHOR => 'Peter Karman <perl at peknet.com>',
+ VERSION_FROM => 'lib/CatalystX/CRUD.pm',
+ ABSTRACT_FROM => 'lib/CatalystX/CRUD.pm',
+ PL_FILES => {},
+ PREREQ_PM => {
+ 'Test::More' => 0,
+ 'Data::Pageset' => 0,
+ 'Class::Accessor::Fast' => 0,
+ 'Catalyst::Component::ACCEPT_CONTEXT' => 0,
+ 'Catalyst::Runtime' => 0,
+ 'Catalyst::Exception' => 0,
+ 'Path::Class::File' => 0,
+ 'NEXT' => 0,
+ 'Data::Dump' => 0, # for testing
+ 'Sort::SQL' => 0.03,
+
+ },
+ dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', },
+ clean => { FILES => 'CatalystX-CRUD-*' },
+);
Added: CatalystX-CRUD/CatalystX-CRUD/trunk/README
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/README (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/README 2008-03-11 17:19:03 UTC (rev 7485)
@@ -0,0 +1,38 @@
+CatalystX-CRUD
+
+INSTALLATION
+
+To install this module, run the following commands:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
+
+SUPPORT AND DOCUMENTATION
+
+After installing, you can find documentation for this module with the perldoc command.
+
+ perldoc CatalystX::CRUD
+
+You can also look for information at:
+
+ Search CPAN
+ http://search.cpan.org/dist/CatalystX-CRUD
+
+ CPAN Request Tracker:
+ http://rt.cpan.org/NoAuth/Bugs.html?Dist=CatalystX-CRUD
+
+ AnnoCPAN, annotated CPAN documentation:
+ http://annocpan.org/dist/CatalystX-CRUD
+
+ CPAN Ratings:
+ http://cpanratings.perl.org/d/CatalystX-CRUD
+
+COPYRIGHT AND LICENCE
+
+Copyright (C) 2007 Peter Karman
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
Added: CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Controller.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Controller.pm (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Controller.pm 2008-03-11 17:19:03 UTC (rev 7485)
@@ -0,0 +1,624 @@
+package CatalystX::CRUD::Controller;
+use strict;
+use warnings;
+use base qw(
+ CatalystX::CRUD
+ Catalyst::Controller
+);
+use Carp;
+
+our $VERSION = '0.26';
+
+=head1 NAME
+
+CatalystX::CRUD::Controller - base class for CRUD controllers
+
+=head1 SYNOPSIS
+
+ # create a controller
+ package MyApp::Controller::Foo;
+ use strict;
+ use base qw( CatalystX::CRUD::Controller );
+
+ __PACKAGE__->config(
+ form_class => 'MyForm::Foo',
+ init_form => 'init_with_foo',
+ init_object => 'foo_from_form',
+ default_template => 'path/to/foo/edit.tt',
+ model_name => 'Foo',
+ primary_key => 'id',
+ view_on_single_result => 0,
+ page_size => 50,
+ allow_GET_writes => 0,
+ );
+
+ 1;
+
+ # now you can manage Foo objects using your MyForm::Foo form class
+ # with URIs at:
+ # foo/<pk>/edit
+ # foo/<pk>/view
+ # foo/<pk>/save
+ # foo/<pk>/rm
+ # foo/create
+ # foo/list
+ # foo/search
+
+=head1 DESCRIPTION
+
+CatalystX::CRUD::Controller is a base class for writing controllers that
+play nicely with the CatalystX::CRUD::Model API. The basic controller API
+is based on Catalyst::Controller::Rose::CRUD and Catalyst::Controller::Rose::Search.
+
+See CatalystX::CRUD::Controller::RHTMLO for one implementation.
+
+=head1 CONFIGURATION
+
+See the L<SYNOPSIS> section.
+
+The configuration values are used extensively in the methods
+described below and are noted B<in bold> where they are used.
+
+=head1 URI METHODS
+
+The following methods are either public via the default URI namespace or
+(as with auto() and fetch()) are called via the dispatch chain. See the L<SYNOPSIS>.
+
+=head2 auto
+
+Attribute: Private
+
+Calls the form() method and saves the return value in stash() as C<form>.
+
+=cut
+
+sub auto : Private {
+ my ( $self, $c, @args ) = @_;
+ $c->stash->{form} = $self->form($c);
+ 1;
+}
+
+=head2 default
+
+Attribute: Private
+
+The fallback method. The default is simply to write a warning to the Catalyst
+log() method.
+
+=cut
+
+sub default : Private {
+ my ( $self, $c, @args ) = @_;
+ $c->log->warn("no action defined for the default() CRUD method");
+}
+
+=head2 fetch( I<primary_key> )
+
+Attribute: chained to namespace, expecting one argument.
+
+Calls B<model_name> read() method with a single key/value pair,
+using the B<primary_key> config value as the key and the I<primary_key> as the value.
+
+The return value of read() is saved in stash() as C<object>.
+
+The I<primary_key> value is saved in stash() as C<object_id>.
+
+=cut
+
+sub fetch : Chained('/') PathPrefix CaptureArgs(1) {
+ my ( $self, $c, $id ) = @_;
+ $c->stash->{object_id} = $id;
+ $c->log->debug("fetching id = $id") if $c->debug;
+ my @arg = $id ? ( $self->primary_key() => $id ) : ();
+ $c->stash->{object} = $c->model( $self->model_name )->fetch(@arg);
+ if ( $self->has_errors($c) or !$c->stash->{object} ) {
+ $self->throw_error( 'No such ' . $self->model_name );
+ }
+}
+
+=head2 create
+
+Attribute: Local
+
+Namespace for creating a new object. Forwards to fetch() and edit()
+with a B<primary_key> value of C<0> (zero).
+
+=cut
+
+sub create : Local {
+ my ( $self, $c ) = @_;
+ $c->forward( 'fetch', [0] );
+ $c->detach('edit');
+}
+
+=head2 edit
+
+Attribute: chained to fetch(), expecting no arguments.
+
+Checks the can_write() and has_errors() methods before proceeding.
+
+Populates the C<form> in stash() with the C<object> in stash(),
+using the B<init_form> method. Sets the C<template> value in stash()
+to B<default_template>.
+
+=cut
+
+sub edit : PathPart Chained('fetch') Args(0) {
+ my ( $self, $c ) = @_;
+ return if $self->has_errors($c);
+ unless ( $self->can_write($c) ) {
+ $self->throw_error('Permission denied');
+ return;
+ }
+ my $meth = $self->init_form;
+ $c->stash->{form}->$meth( $c->stash->{object} );
+
+ # might get here from create()
+ $c->stash->{template} = $self->default_template;
+}
+
+=head2 view
+
+Attribute: chained to fetch(), expecting no arguments.
+
+Checks the can_read() and has_errors() methods before proceeding.
+
+Acts the same as edit() but does not set template value in stash().
+
+=cut
+
+sub view : PathPart Chained('fetch') Args(0) {
+ my ( $self, $c ) = @_;
+ return if $self->has_errors($c);
+ unless ( $self->can_read($c) ) {
+ $self->throw_error('Permission denied');
+ return;
+ }
+ my $meth = $self->init_form;
+ $c->stash->{form}->$meth( $c->stash->{object} );
+}
+
+=head2 save
+
+Attribute: chained to fetch(), expecting no arguments.
+
+Creates an object with form_to_object(), then follows the precommit(),
+save_obj() and postcommit() logic.
+
+See the save_obj(), precommit() and postcommit() hook methods for
+ways to affect the behaviour of save().
+
+The special param() value C<_delete> is checked to support POST requests
+to /save. If found, save() will detach() to rm().
+
+save() returns 0 on any error, and returns 1 on success.
+
+=cut
+
+sub save : PathPart Chained('fetch') Args(0) {
+ my ( $self, $c ) = @_;
+
+ if ( !$self->allow_GET_writes ) {
+ if ( $c->req->method ne 'POST' ) {
+ $self->throw_error('GET request not allowed');
+ return;
+ }
+ }
+
+ if ( $c->request->param('_delete') ) {
+ $c->action->name('rm'); # so we can test against it in postcommit()
+ $self->rm($c);
+ return;
+ }
+
+ return if $self->has_errors($c);
+ unless ( $self->can_write($c) ) {
+ $self->throw_error('Permission denied');
+ return;
+ }
+
+ # get a valid object
+ my $obj = $self->form_to_object($c);
+ if ( !$obj ) {
+ return 0;
+ }
+
+ # write our changes
+ unless ( $self->precommit( $c, $obj ) ) {
+ $c->stash->{template} ||= $self->default_template;
+ return 0;
+ }
+ $self->save_obj( $c, $obj );
+ $self->postcommit( $c, $obj );
+
+ 1;
+}
+
+=head2 rm
+
+Attribute: chained to fetch(), expecting no arguments.
+
+Checks the can_write() and has_errors() methods before proceeeding.
+
+Calls the delete() method on the C<object>.
+
+=cut
+
+sub rm : PathPart Chained('fetch') Args(0) {
+ my ( $self, $c ) = @_;
+ if ( !$self->allow_GET_writes ) {
+ if ( $c->req->method ne 'POST' ) {
+ $self->throw_error('GET request not allowed');
+ return;
+ }
+ }
+ return if $self->has_errors($c);
+ unless ( $self->can_write($c) ) {
+ $self->throw_error('Permission denied');
+ return;
+ }
+
+ my $o = $c->stash->{object};
+
+ unless ( $self->precommit( $c, $o ) ) {
+ return 0;
+ }
+ $o->delete;
+ $self->postcommit( $c, $o );
+}
+
+=head2 list
+
+Attribute: Local
+
+Display all the objects represented by model_name().
+The same as calling search() with no params().
+See do_search().
+
+=cut
+
+sub list : Local {
+ my ( $self, $c, @arg ) = @_;
+ unless ( $self->can_read($c) ) {
+ $self->throw_error('Permission denied');
+ return;
+ }
+
+ $self->do_search( $c, @arg );
+}
+
+=head2 search
+
+Attribute: Local
+
+Query the model and return results. See do_search().
+
+=cut
+
+sub search : Local {
+ my ( $self, $c, @arg ) = @_;
+ unless ( $self->can_read($c) ) {
+ $self->throw_error('Permission denied');
+ return;
+ }
+
+ $self->do_search( $c, @arg );
+}
+
+=head2 count
+
+Attribute: Local
+
+Like search() but does not set result values, only a total count.
+Useful for AJAX-y types of situations where you want to query for a total
+number of matches and create a pager but not actually retrieve any data.
+
+=cut
+
+sub count : Local {
+ my ( $self, $c, @arg ) = @_;
+ unless ( $self->can_read($c) ) {
+ $self->throw_error('Permission denied');
+ return;
+ }
+
+ $c->stash->{fetch_no_results} = 1;
+
+ $self->do_search( $c, @arg );
+}
+
+=head1 INTERNAL METHODS
+
+The following methods are not visible via the URI namespace but
+directly affect the dispatch chain.
+
+=head2 form
+
+Returns an instance of config->{form_class}. A single form object is instantiated and
+cached in the controller object. If the form object has a C<clear> or C<reset>
+method it will be called before returning.
+
+=cut
+
+sub form {
+ my $self = shift;
+ $self->{_form} ||= $self->form_class->new;
+ if ( $self->{_form}->can('clear') ) {
+ $self->{_form}->clear;
+ }
+ elsif ( $self->{_form}->can('reset') ) {
+ $self->{_form}->reset;
+ }
+ return $self->{_form};
+}
+
+=head2 field_names
+
+Returns an array ref of the field names in form(). By default just calls the field_names()
+method on the form(). Your subclass should implement this method if your form class does
+not have a field_names() method.
+
+=cut
+
+sub field_names {
+ my ($self) = @_;
+ return $self->form->field_names;
+}
+
+=head2 can_read( I<context> )
+
+Returns true if the current request is authorized to read() the C<object> in
+stash().
+
+Default is true.
+
+=cut
+
+sub can_read {1}
+
+=head2 can_write( I<context> )
+
+Returns true if the current request is authorized to create() or update()
+the C<object> in stash().
+
+=cut
+
+sub can_write {1}
+
+=head2 form_to_object( I<context> )
+
+Should return an object ready to be handed to save_obj(). This is the primary
+method to override in your subclass, since it will handle all the form validation
+and population of the object.
+
+If form_to_object() returns 0, save() will abort at that point in the process,
+so form_to_object() should set whatever template and other stash() values
+should be used in the response.
+
+Will throw_error() if not overridden.
+
+See CatalystX::CRUD::Controller::RHTMLO for an example.
+
+=cut
+
+sub form_to_object {
+ shift->throw_error("must override form_to_object()");
+}
+
+=head2 save_obj( I<context>, I<object> )
+
+Calls the update() or create() method on the I<object>, picking the method
+based on whether C<object_id> in stash() evaluates true (update) or false (create).
+
+=cut
+
+sub save_obj {
+ my ( $self, $c, $obj ) = @_;
+ my $method = $c->stash->{object_id} ? 'update' : 'create';
+ $obj->$method;
+}
+
+=head2 precommit( I<context>, I<object> )
+
+Called by save(). If precommit() returns a false value, save() is aborted.
+If precommit() returns a true value, save_obj() gets called.
+
+The default return is true.
+
+=cut
+
+sub precommit {1}
+
+=head2 postcommit( I<context>, I<object> )
+
+Called in save() after save_obj(). The default behaviour is to issue an external
+redirect resolving to view().
+
+=cut
+
+sub postcommit {
+ my ( $self, $c, $o ) = @_;
+ my $pk = $self->primary_key;
+
+ if ( $c->action->name eq 'rm' ) {
+ $c->response->redirect( $c->uri_for('') );
+ }
+ else {
+ $c->response->redirect(
+ $c->uri_for( '', $o->delegate->$pk, 'view' ) );
+ }
+
+ 1;
+}
+
+=head2 view_on_single_result( I<context>, I<results> )
+
+Returns 0 unless the config() key of the same name is true.
+
+Otherwise, calls the primary_key() value on the first object
+in I<results> and constructs a uri_for() value to the edit()
+action in the same class as the current action.
+
+=cut
+
+sub view_on_single_result {
+ my ( $self, $c, $results ) = @_;
+ return 0 unless $self->config->{view_on_single_result};
+ my $pk = $self->primary_key;
+ my $obj = $results->[0];
+
+ # the append . '' is to force stringify anything
+ # that might be an object with overloading. Otherwise
+ # uri_for() assumes it is an Action object.
+ return $c->uri_for( $obj->$pk . '',
+ $self->can_write($c) ? 'edit' : 'view' );
+}
+
+=head2 do_search( I<context>, I<arg> )
+
+Prepare and execute a search. Called internally by list()
+and search().
+
+=cut
+
+sub do_search {
+ my ( $self, $c, @arg ) = @_;
+
+ # stash the form so it can be re-displayed
+ # subclasses must stick-ify it in their own way.
+ $c->stash->{form} ||= $self->form;
+
+ # if we have no input, just return for initial search
+ if ( !@arg && !$c->req->param && $c->action->name eq 'search' ) {
+ return;
+ }
+
+ # turn flag on if explicitly turned off
+ $c->stash->{view_on_single_result} = 1
+ unless exists $c->stash->{view_on_single_result};
+
+ my $query = $c->model( $self->model_name )->make_query(@arg);
+ my $count = $c->model( $self->model_name )->count($query) || 0;
+ my $results;
+ unless ( $c->stash->{fetch_no_results} ) {
+ $results = $c->model( $self->model_name )->search($query);
+ }
+ if ( $results
+ and $count == 1
+ and $c->stash->{view_on_single_result}
+ and ( my $uri = $self->view_on_single_result( $c, $results ) ) )
+ {
+ $c->response->redirect($uri);
+ }
+ else {
+ $c->stash->{results} = {
+ count => $count,
+ pager => $count
+ ? ( $c->model( $self->model_name )->make_pager( $count, $results )
+ || undef )
+ : undef,
+ results => $results,
+ query => $query,
+ };
+ }
+}
+
+=head1 CONVENIENCE METHODS
+
+The following methods simply return the config() value of the same name.
+
+=over
+
+=item form_class
+
+=item init_form
+
+=item init_object
+
+=item model_name
+
+=item default_template
+
+=item primary_key
+
+=item page_size
+
+=item allow_GET_writes
+
+=back
+
+=cut
+
+sub form_class { shift->config->{form_class} }
+sub init_form { shift->config->{init_form} }
+sub init_object { shift->config->{init_object} }
+sub model_name { shift->config->{model_name} }
+sub default_template { shift->config->{default_template} }
+sub primary_key { shift->config->{primary_key} }
+sub allow_GET_writes { shift->config->{allow_GET_writes} }
+
+# see http://use.perl.org/~LTjake/journal/31738
+# PathPrefix will likely end up in an official Catalyst RSN.
+# This lets us have a sane default fetch() method without having
+# to write one in each subclass.
+sub _parse_PathPrefix_attr {
+ my ( $self, $c, $name, $value ) = @_;
+ return PathPart => $self->path_prefix;
+}
+
+1;
+
+__END__
+
+=head1 AUTHOR
+
+Peter Karman, C<< <perl at peknet.com> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-catalystx-crud at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CatalystX-CRUD>.
+I will be notified, and then you'll automatically be notified of progress on
+your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc CatalystX::CRUD
+
+You can also look for information at:
+
+=over 4
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/CatalystX-CRUD>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/CatalystX-CRUD>
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=CatalystX-CRUD>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/CatalystX-CRUD>
+
+=back
+
+=head1 ACKNOWLEDGEMENTS
+
+This module based on Catalyst::Controller::Rose::CRUD by the same author.
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2007 Peter Karman, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
Added: CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Iterator/File.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Iterator/File.pm (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Iterator/File.pm 2008-03-11 17:19:03 UTC (rev 7485)
@@ -0,0 +1,119 @@
+package CatalystX::CRUD::Iterator::File;
+use strict;
+use warnings;
+use Carp;
+
+our $VERSION = '0.26';
+
+=head1 NAME
+
+CatalystX::CRUD::Iterator::File - simple iterator for CXCO::File objects
+
+=head1 SYNOPSIS
+
+ my $iterator = $c->model('MyFile')->iterator;
+ while (my $file = $iterator->next)
+ {
+ # $file is a CatalystX::CRUD::Object::File
+ # ...
+ }
+
+
+=head1 DESCRIPTION
+
+CatalystX::CRUD::Iterator::File is a simple iterator to fulfull the
+CatalystX::CRUD::Model::File API.
+
+=cut
+
+=head1 METHODS
+
+=head2 new( I<files> )
+
+Returns an iterator for I<files>. I<files> should be an array ref.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $files = shift or croak "need files array";
+ return bless( $files, $class );
+}
+
+=head2 next
+
+Returns the next File object or undef if no more files remain.
+
+=cut
+
+sub next {
+ my $self = shift;
+ return shift(@$self);
+}
+
+=head2 finish
+
+Sets the array ref to empty. Always returns 1. This method is
+generally useless but implemented for completeness' sake.
+
+=cut
+
+sub finish {
+ my $self = shift;
+ my $class = ref $self;
+ $self = bless( [], $class );
+ return 1;
+}
+
+1;
+
+__END__
+
+=head1 AUTHOR
+
+Peter Karman, C<< <perl at peknet.com> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-catalystx-crud at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CatalystX-CRUD>.
+I will be notified, and then you'll automatically be notified of progress on
+your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc CatalystX::CRUD
+
+You can also look for information at:
+
+=over 4
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/CatalystX-CRUD>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/CatalystX-CRUD>
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=CatalystX-CRUD>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/CatalystX-CRUD>
+
+=back
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2007 Peter Karman, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
Added: CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Iterator.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Iterator.pm (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Iterator.pm 2008-03-11 17:19:03 UTC (rev 7485)
@@ -0,0 +1,171 @@
+package CatalystX::CRUD::Iterator;
+use strict;
+use warnings;
+use Carp;
+use base qw( CatalystX::CRUD );
+
+our $VERSION = '0.26';
+
+=head1 NAME
+
+CatalystX::CRUD::Iterator - generic iterator wrapper for CXCM iterator() results
+
+=head1 SYNOPSIS
+
+ package MyApp::Model::MyModel;
+ use CatalystX::CRUD::Iterator;
+ use MyModel;
+ __PACKAGE__->config->{object_class} = 'MyModel::Object';
+
+ sub iterator {
+ my ($self, $query) = @_;
+
+ my $iterator = MyModel->search_for_something;
+
+ # $iterator must have a next() method
+
+ return CatalystX::CRUD::Iterator->new(
+ $iterator,
+ $self->object_class
+ );
+ }
+
+=head1 DESCRIPTION
+
+CatalystX::CRUD::Iterator is a general iterator class that wraps
+a real iterator and blesses return results into a specified class.
+CatalystX::CRUD::Iterator is a glue that provides
+for a similar level of abstraction across all kinds of CXCM classes.
+
+=cut
+
+=head1 METHODS
+
+=head2 new( I<iterator>, I<class_name> )
+
+Returns a CatalystX::CRUD::Iterator instance.
+
+I<iterator> must have a next() method and (optionally) a finish() method.
+
+See next().
+
+=cut
+
+# hasa a CXCM iterator() result and calls its next() method,
+# wrapping the result in the Iterator's CXCO class instance
+
+sub new {
+ my $class = shift;
+ my $iterator = shift or $class->throw_error("need an iterator object");
+ my $cxco_class = shift
+ or $class->throw_error("need the name of a CXCO class");
+
+ # sanity checks
+ unless ( $iterator->can('next') ) {
+ $class->throw_error("iterator $iterator has no next() method");
+ }
+
+ unless ( $cxco_class->can('new') ) {
+ $class->throw_error("no new() method defined for $cxco_class");
+ }
+
+ unless ( $cxco_class->isa('CatalystX::CRUD::Object') ) {
+ $class->throw_error(
+ "$cxco_class does not inherit from CatalystX::CRUD::Object");
+ }
+
+ return bless(
+ { iterator => $iterator,
+ cxco => $cxco_class
+ },
+ $class
+ );
+}
+
+=head2 next
+
+Calls the next() method on the internal I<iterator> object,
+stashing the result in an object returned by I<class_name>->new
+under the I<method_name> accessor.
+
+=cut
+
+sub next {
+ my $self = shift;
+ my $next = $self->{iterator}->next;
+ return unless $next;
+
+ my $obj = $self->{cxco}->new;
+ $obj->{delegate} = $next;
+ return $obj;
+}
+
+=head2 finish
+
+If the internal I<iterator> object has a finish() method,
+this will call and return it. Otherwise returns true (1).
+
+=cut
+
+sub finish {
+ my $self = shift;
+ if ( $self->{iterator}->can('finish') ) {
+ return $self->{iterator}->finish;
+ }
+ return 1;
+}
+
+1;
+
+__END__
+
+=head1 AUTHOR
+
+Peter Karman, C<< <perl at peknet.com> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-catalystx-crud at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CatalystX-CRUD>.
+I will be notified, and then you'll automatically be notified of progress on
+your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc CatalystX::CRUD
+
+You can also look for information at:
+
+=over 4
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/CatalystX-CRUD>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/CatalystX-CRUD>
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=CatalystX-CRUD>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/CatalystX-CRUD>
+
+=back
+
+=head1 ACKNOWLEDGEMENTS
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2007 Peter Karman, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
Added: CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Model/File.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Model/File.pm (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Model/File.pm 2008-03-11 17:19:03 UTC (rev 7485)
@@ -0,0 +1,216 @@
+package CatalystX::CRUD::Model::File;
+use strict;
+use warnings;
+use base qw( CatalystX::CRUD::Model );
+use File::Find;
+use Carp;
+use Data::Dump qw( dump );
+use Path::Class::File;
+
+our $VERSION = '0.26';
+
+=head1 NAME
+
+CatalystX::CRUD::Model::File - filesystem CRUD model
+
+=head1 SYNOPSIS
+
+ package MyApp::Model::Foo;
+ use base qw( CatalystX::CRUD::Model::File );
+ __PACKAGE__->config->{object_class} = 'MyApp::File';
+ __PACKAGE__->config->{inc_path} = [ '/some/path', '/other/path' ];
+
+ 1;
+
+=head1 DESCRIPTION
+
+CatalystX::CRUD::Model::File is an example implementation of CatalystX::CRUD::Model.
+
+=head1 METHODS
+
+Only new or overridden methods are documented here.
+
+=cut
+
+=head2 Xsetup
+
+Implements the CXC::Model API. Sets the C<inc_path> config (if not already set)
+to the C<root> config value.
+
+=cut
+
+sub Xsetup {
+ my ( $self, $c ) = @_;
+ $self->config->{inc_path} ||= [ $c->config->{root} ];
+ $self->NEXT::Xsetup($c);
+}
+
+=head2 new_object( file => I<path/to/file> )
+
+Return a new CatalystX::CRUD::Object::File object.
+
+=cut
+
+=head2 fetch( file => I<path/to/file> )
+
+Read I<path/to/file> from disk and return a CXCO::File object.
+
+I<path/to/file> is assumed to be in C<inc_path>
+
+If I<path/to/file> is empty or cannot be found, undef is returned.
+
+=cut
+
+sub fetch {
+ my $self = shift;
+ my $file = $self->new_object(@_);
+
+ # look through inc_path
+ for my $dir ( @{ $self->inc_path } ) {
+ my $test = $self->object_class->new(
+ file => Path::Class::File->new( $dir, $file ) );
+
+ if ( -s $test ) {
+ $file = $test;
+ $file->read;
+ last;
+ }
+ }
+
+ return -s $file ? $file : undef;
+}
+
+=head2 inc_path
+
+Returns the include path from config(). The include path is searched
+by search(), count() and iterator().
+
+=cut
+
+sub inc_path { shift->config->{inc_path} }
+
+=head2 make_query
+
+Returns a I<wanted> subroutine suitable for File::Find.
+
+ # TODO regex vs exact match
+
+=cut
+
+sub make_query {
+ my ($self) = @_;
+ return sub {1};
+}
+
+=head2 search( I<filter_CODE> )
+
+Uses File::Find to search through inc_path() for files.
+I<filter_CODE> should be a CODE ref matching format returned by make_query().
+If not set, make_query() is called by default.
+
+Returns an array ref of CXCO::File objects.
+
+=cut
+
+sub search {
+ my $self = shift;
+ my $filter_sub = shift || $self->make_query;
+ my %files;
+ my $find_sub = sub {
+
+ carp "File::Find::Dir = $File::Find::dir\nfile = $_\n";
+ return unless $filter_sub->($_);
+ $files{$File::Find::name}++;
+ };
+ find( $find_sub, @{ $self->inc_path } );
+
+ carp dump \%files;
+
+ return [ map { $self->new_object( file => $_ ) } sort keys %files ];
+}
+
+=head2 count( I<filter_CODE> )
+
+Returns number of files matching I<filter_CODE>. See search for a description
+of I<filter_CODE>.
+
+=cut
+
+sub count {
+ my $self = shift;
+ my $filter_sub = shift || $self->make_query;
+ my $count;
+ my $find_sub = sub {
+ carp "File::Find::Dir = $File::Find::dir\nfile = $_\n";
+ return unless $filter_sub->($_);
+ $count++;
+ };
+ find( $find_sub, @{ $self->inc_path } );
+ return $count;
+}
+
+=head2 iterator( I<filter_CODE> )
+
+Acts same as search() but returns a CatalystX::CRUD::Iterator::File
+object instead of a simple array ref.
+
+=cut
+
+sub iterator {
+ my $self = shift;
+ my $files = $self->search(@_);
+ return CatalystX::CRUD::Iterator::File->new($files);
+}
+
+1;
+
+__END__
+
+=head1 AUTHOR
+
+Peter Karman, C<< <perl at peknet.com> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-catalystx-crud at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CatalystX-CRUD>.
+I will be notified, and then you'll automatically be notified of progress on
+your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc CatalystX::CRUD
+
+You can also look for information at:
+
+=over 4
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/CatalystX-CRUD>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/CatalystX-CRUD>
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=CatalystX-CRUD>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/CatalystX-CRUD>
+
+=back
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2007 Peter Karman, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
Added: CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Model/Utils.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Model/Utils.pm (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Model/Utils.pm 2008-03-11 17:19:03 UTC (rev 7485)
@@ -0,0 +1,283 @@
+package CatalystX::CRUD::Model::Utils;
+use strict;
+use warnings;
+use base qw( CatalystX::CRUD Class::Accessor::Fast );
+use Sort::SQL;
+__PACKAGE__->mk_accessors(qw( use_ilike ne_sign ));
+
+our $VERSION = '0.26';
+
+=head1 NAME
+
+CatalystX::CRUD::Model::Utils - helpful methods for your CRUD Model class
+
+=head1 SYNOPSIS
+
+ package MyApp::Model::Foo;
+ use base qw(
+ CatalystX::CRUD::Model
+ CatalystX::CRUD::Model::Utils
+ );
+ # ...
+ 1;
+
+=head1 DESCRIPTION
+
+CatalystX::CRUD::Model::Utils provides helpful not non-essential methods
+for CRUD Model implementations. Stick it in your @ISA to help reduce the
+amount of code you have to write yourself.
+
+=head1 METHODS
+
+=head2 use_ilike( boolean )
+
+Convenience accessor to flag requests in params_to_sql_query()
+to use ILIKE instead of LIKE SQL command.
+
+=head2 ne_sign( I<string> )
+
+What string to use for 'not equal' in params_to_sql_query().
+Defaults to '!='.
+
+=head2 treat_like_int
+
+Should return a hashref of column names to treat as integers
+instead of text strings when parsing wildcard request params. Example
+might be all date/timestamp columns.
+
+=cut
+
+=head2 make_sql_query( [ I<field_names> ] )
+
+Returns a hashref suitable for passing to a SQL-oriented model.
+
+I<field_names> should be an array of valid form field names.
+If false or missing, will call $c->controller->field_names().
+
+The following reserved request param names are implemented:
+
+=over
+
+=item _order
+
+Sort order. Should be a SQL-friendly string parse-able by Sort::SQL.
+
+=item _sort
+
+Instead of _order, can pass one column name to sort by.
+
+=item _dir
+
+With _sort, pass the direction in which to sort.
+
+=item _page_size
+
+For the Data::Pageset pager object. Defaults to page_size(). An upper limit of 200
+is implemented by default to reduce the risk of a user [unwittingly] creating a denial
+of service situation.
+
+=item _page
+
+What page the current request is coming from. Used to set the offset value
+in the query. Defaults to C<1>.
+
+=item _offset
+
+Pass explicit row to offset from in query. If not present, deduced from
+_page and _page_size.
+
+=item _no_page
+
+Ignore _page_size, _page and _offset and do not return a limit
+or offset value.
+
+=back
+
+=cut
+
+sub make_sql_query {
+ my $self = shift;
+ my $c = $self->context;
+ my $field_names = shift
+ || $c->controller->field_names
+ || $self->throw_error("field_names required");
+
+ my $p2q = $self->params_to_sql_query($field_names);
+ my $sp
+ = Sort::SQL->string2array( $c->req->param('_order')
+ || join( ' ', $c->req->param('_sort'), $c->req->param('_dir') )
+ || ( $c->controller->primary_key . ' DESC' ) );
+ my $s = join( ' ', map { each %$_ } @$sp );
+ my $offset = $c->req->param('_offset');
+ my $page_size = $c->request->param('_page_size') || $self->page_size;
+
+ # don't let users DoS us. unless they ask to (see _no_page).
+ $page_size = 200 if $page_size > 200;
+
+ my $page = $c->req->param('_page') || 1;
+
+ if ( !defined($offset) ) {
+ $offset = ( $page - 1 ) * $page_size;
+ }
+
+ # normalize since some ORMs require UPPER case
+ $s =~ s,\b(asc|desc)\b,uc($1),eg;
+
+ my %query = (
+ query => $p2q->{sql},
+ sort_by => $s,
+ limit => $page_size,
+ offset => $offset,
+ sort_order => $sp,
+ plain_query => $p2q->{query},
+ plain_query_str => $self->sql_query_as_string( $p2q->{query} ),
+ );
+
+ # undo what we've done if asked.
+ if ( $c->req->param('_no_page') ) {
+ delete $query{limit};
+ delete $query{offset};
+ }
+
+ return \%query;
+
+}
+
+=head2 sql_query_as_string( params_to_sql_query->{query} )
+
+Returns the request params as a SQL WHERE string.
+
+=cut
+
+sub sql_query_as_string {
+ my ( $self, $q ) = @_;
+ my @s;
+ for my $p ( sort keys %$q ) {
+ my @v = @{ $q->{$p} };
+ next unless grep {m/\S/} @v;
+ push( @s, "$p = " . join( ' or ', @v ) );
+ }
+ return join( ' AND ', @s );
+}
+
+=head2 params_to_sql_query( I<field_names> )
+
+Convert request->params into a SQL-oriented
+query.
+
+Returns a hashref with two key/value pairs:
+
+=over
+
+=item sql
+
+Arrayref of ORM-friendly SQL constructs.
+
+=item query
+
+Hashref of column_name => raw_values_as_arrayref.
+
+=back
+
+Called internally by make_sql_query().
+
+=cut
+
+sub params_to_sql_query {
+ my ( $self, $field_names ) = @_;
+ my $c = $self->context;
+ my ( @sql, %query );
+ my $ne = $self->ne_sign || '!=';
+ my $like = $self->use_ilike ? 'ilike' : 'like';
+ my $treat_like_int
+ = $self->can('treat_like_int') ? $self->treat_like_int : {};
+
+ for my $p (@$field_names) {
+
+ next unless exists $c->req->params->{$p};
+ my @v = $c->req->param($p);
+ my @safe = @v;
+ next unless grep { defined && m/./ } @safe;
+
+ $query{$p} = \@v;
+
+ # normalize wildcards and set sql
+ if ( grep {/[\%\*]|^!/} @v ) {
+ grep {s/\*/\%/g} @safe;
+ my @wild = grep {m/\%/} @safe;
+ if (@wild) {
+ if ( exists $treat_like_int->{$p} ) {
+ push( @sql,
+ ( $p => { 'ge' => [ map {m/^(.+?)\%/} @wild ] } ) );
+ }
+ else {
+ push( @sql, ( $p => { $like => \@wild } ) );
+ }
+ }
+
+ # allow for negation of query
+ my @not = grep {m/^!/} @safe;
+ if (@not) {
+ push( @sql, ( $p => { $ne => [ grep {s/^!//} @not ] } ) );
+ }
+ }
+ else {
+ push( @sql, $p => [@safe] );
+ }
+ }
+
+ return { sql => \@sql, query => \%query };
+}
+
+1;
+
+__END__
+
+=head1 AUTHOR
+
+Peter Karman, C<< <perl at peknet.com> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-catalystx-crud at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CatalystX-CRUD>.
+I will be notified, and then you'll automatically be notified of progress on
+your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc CatalystX::CRUD
+
+You can also look for information at:
+
+=over 4
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/CatalystX-CRUD>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/CatalystX-CRUD>
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=CatalystX-CRUD>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/CatalystX-CRUD>
+
+=back
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2007 Peter Karman, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
Added: CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Model.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Model.pm (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Model.pm 2008-03-11 17:19:03 UTC (rev 7485)
@@ -0,0 +1,349 @@
+package CatalystX::CRUD::Model;
+use strict;
+use warnings;
+use base qw(
+ CatalystX::CRUD
+ Catalyst::Component::ACCEPT_CONTEXT
+ Catalyst::Model
+);
+use Carp;
+use Data::Pageset;
+
+our $VERSION = '0.26';
+
+__PACKAGE__->mk_accessors(qw( object_class ));
+
+=head1 NAME
+
+CatalystX::CRUD::Model - base class for CRUD models
+
+=head1 SYNOPSIS
+
+ package MyApp::Model::Foo;
+ use base qw( CatalystX::CRUD::Model );
+
+ __PACKAGE__->config(
+ object_class => 'MyApp::Foo',
+ page_size => 50,
+ );
+
+ # must define the following methods
+ sub new_object { }
+ sub fetch { }
+ sub search { }
+ sub iterator { }
+ sub count { }
+
+ 1;
+
+=head1 DESCRIPTION
+
+CatalystX::CRUD::Model provides a high-level API for writing Model
+classes. CatalystX::CRUD::Model methods typically return CatalystX::CRUD::Object
+objects.
+
+This documentation is intended for Model developers.
+
+=head1 CONFIGURATION
+
+You may configure your CXCM-derived Models in the usual way (see the Catalyst
+Manual).
+
+If the C<object_class> key/value pair is set at initialization time, the value
+will be stored in the object_class() accessor. This feature is intended as a
+convenience for setting the name of the CatalystX::CRUD::Object class to which
+your CatalystX::CRUD::Model acts as an interface.
+
+=head1 METHODS
+
+CatalystX::CRUD::Model inherits from Catalyst::Component::ACCEPT_CONTEXT
+and Catalyst::Model. New and overridden methods are documented here.
+
+=head2 context
+
+This accessor is available via Catalyst::Component::ACCEPT_CONTEXT and
+returns the C<$c> value for the current request.
+
+This method is not implemented at the CatalystX::CRUD::Model level but is
+highlighted here in order to remind developers that it exists.
+
+=head2 object_class
+
+The object_class() accessor is defined for your convenience. It is set
+by the default Xsetup() method if a key called C<object_class> is present
+in config() at initialization time.
+
+=cut
+
+=head2 new
+
+Overrides the Catalyst::Model new() method to call Xsetup().
+
+=cut
+
+sub new {
+ my ( $class, $c, @arg ) = @_;
+ my $self = $class->NEXT::new( $c, @arg );
+ $self->Xsetup( $c, @arg );
+ return $self;
+}
+
+=head2 Xsetup
+
+Called by new() at application startup time. Override this method
+in order to set up your model in whatever way you require.
+
+Xsetup() is called by new(), which in turn is called by COMPONENT().
+Keep that order in mind when overriding Xsetup(), notably that config()
+has already been merged by the time Xsetup() is called.
+
+=cut
+
+sub Xsetup {
+ my ( $self, $c, $arg ) = @_;
+ if ( exists $self->config->{object_class} ) {
+ my $object_class = $self->config->{object_class};
+ eval "require $object_class";
+ if ($@) {
+ $self->throw_error("$object_class could not be loaded: $@");
+ }
+ $self->object_class($object_class);
+
+ # some black magic hackery to make Object classes act like
+ # they're overloaded delegate()s
+ {
+ no strict 'refs';
+ no warnings 'redefine';
+ *{ $object_class . '::AUTOLOAD' } = sub {
+ my $obj = shift;
+ my $obj_class = ref($obj) || $obj;
+ my $method = our $AUTOLOAD;
+ $method =~ s/.*://;
+ return if $method eq 'DESTROY';
+ if ( $obj->delegate->can($method) ) {
+ return $obj->delegate->$method(@_);
+ }
+
+ $obj->throw_error(
+ "method '$method' not implemented in class '$obj_class'");
+
+ };
+
+ # this overrides the basic $object_class->can
+ # to always call secondary can() on its delegate.
+ # we have to UNIVERSAL::can because we are overriding can()
+ # in $class and would otherwise have a recursive nightmare.
+ *{ $object_class . '::can' } = sub {
+ my ( $obj, $method, @arg ) = @_;
+ if ( ref($obj) ) {
+
+ # object method tries object_class first,
+ # then the delegate().
+ return UNIVERSAL::can( $object_class, $method )
+ || $obj->delegate->can( $method, @arg );
+ }
+ else {
+
+ # class method
+ return UNIVERSAL::can( $object_class, $method );
+ }
+ };
+
+ }
+
+ }
+ if ( !defined $self->config->{page_size} ) {
+ $self->config->{page_size} = 50;
+ }
+ return $self;
+}
+
+=head2 page_size
+
+Returns the C<page_size> set in config().
+
+=cut
+
+sub page_size { shift->config->{page_size} }
+
+=head2 make_pager( I<total>, I<results> )
+
+Returns a Data::Pageset object using I<total>,
+either the C<_page_size> param or the value of page_size(),
+and the C<_page> param or C<1>.
+
+If the C<_no_page> request param is true, will return undef.
+B<NOTE:> Model authors should check (and respect) the C<_no_page>
+param when constructing queries.
+
+=cut
+
+sub make_pager {
+ my ( $self, $count, $results ) = @_;
+ my $c = $self->context;
+ return if $c->req->param('_no_page');
+ return Data::Pageset->new(
+ { total_entries => $count,
+ entries_per_page => $c->req->param('_page_size')
+ || $self->page_size,
+ current_page => $c->req->param('_page')
+ || 1,
+ pages_per_set => 10, #TODO make this configurable?
+ mode => 'slide',
+ }
+ );
+}
+
+=head2 new_object
+
+Returns CatalystX::CRUD::Object->new(). A sane default, assuming
+C<object_class> is set in config(), is implemented in this base class.
+
+
+=head1 REQUIRED METHODS
+
+CXCM subclasses need to implement at least the following methods:
+
+=over
+
+=item fetch
+
+Returns CatalystX::CRUD::Object->new()->read()
+
+=item search
+
+Returns zero or more CXCO instances as an array or arrayref.
+
+=item iterator
+
+Like search() but returns an iterator conforming to the CatalystX::CRUD::Iterator API.
+
+=item count
+
+Like search() but returns an integer.
+
+=back
+
+=cut
+
+sub new_object {
+ my $self = shift;
+ if ( $self->object_class ) {
+ return $self->object_class->new(@_);
+ }
+ else {
+ return $self->throw_error("must implement new_object()");
+ }
+}
+
+sub fetch { shift->throw_error("must implement fetch") }
+sub search { shift->throw_error("must implement search") }
+sub iterator { shift->throw_error("must implement iterator") }
+sub count { shift->throw_error("must implement count") }
+
+=head1 OPTIONAL METHODS
+
+Catalyst components accessing CXCM instances may need to access
+model-specific logic without necessarily knowing what kind of model they
+are accessing.
+An example would be a Controller that wants to remain agnostic about the kind
+of data storage a particular model implements, but also needs to
+create a model-specific query based on request parameters.
+
+ $c->model('Foo')->search(@arg); # @arg depends upon what Foo is
+
+To support this high level of abstraction, CXCM classes may implement
+the following optional methods.
+
+=over
+
+=item make_query
+
+Should return appropriate values for passing to search(), iterator() and
+count(). Example of use:
+
+ # in a CXCM subclass called MyApp::Model::Foo
+ sub search {
+ my $self = shift;
+ my @arg = @_;
+ unless(@arg) {
+ @arg = $self->make_query;
+ }
+ # search code here
+
+ return $results;
+ }
+
+ sub make_query {
+ my $self = shift;
+ my $c = $self->context;
+
+ # use $c->req to get at params() etc.
+ # and create a query
+
+ return $query;
+ }
+
+ # elsewhere in a controller
+
+ my $results = $c->model('Foo')->search; # notice no @arg necessary since
+ # it will default to
+ # $c->model('Foo')->make_query()
+
+
+=back
+
+=cut
+
+1;
+
+__END__
+
+=head1 AUTHOR
+
+Peter Karman, C<< <perl at peknet.com> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-catalystx-crud at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CatalystX-CRUD>.
+I will be notified, and then you'll automatically be notified of progress on
+your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc CatalystX::CRUD
+
+You can also look for information at:
+
+=over 4
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/CatalystX-CRUD>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/CatalystX-CRUD>
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=CatalystX-CRUD>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/CatalystX-CRUD>
+
+=back
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2007 Peter Karman, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
Added: CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Object/File.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Object/File.pm (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Object/File.pm 2008-03-11 17:19:03 UTC (rev 7485)
@@ -0,0 +1,181 @@
+package CatalystX::CRUD::Object::File;
+use strict;
+use warnings;
+use base qw( CatalystX::CRUD::Object );
+use Path::Class::File;
+use Carp;
+use NEXT;
+use overload(
+ q[""] => sub { shift->delegate },
+ fallback => 1,
+);
+
+__PACKAGE__->mk_accessors(qw( buffer ));
+
+our $VERSION = '0.26';
+
+=head1 NAME
+
+CatalystX::CRUD::Object::File - filesystem CRUD instance
+
+=head1 SYNOPSIS
+
+ package My::File;
+ use base qw( CatalystX::CRUD::Object::File );
+
+ 1;
+
+=head1 DESCRIPTION
+
+CatalystX::CRUD::Object::File delegates to Path::Class:File.
+
+=head1 METHODS
+
+Only new or overridden methods are documented here.
+
+=cut
+
+=head2 new( file => I<path/to/file> )
+
+Returns new CXCO::File object.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $self = $class->NEXT::new(@_);
+ my $file = $self->{file} or $self->throw_error("file param required");
+ $self->{delegate} = Path::Class::File->new($file);
+ return $self;
+}
+
+=head2 buffer
+
+The contents of the delegate() file object. Set when you call read().
+Set it yourself and call create() or update() as appropriate to write to the file.
+
+=cut
+
+=head2 create
+
+Writes buffer() to a file. If the file already exists, will throw_error(), so
+call it like:
+
+ -s $file ? $file->update : $file->create;
+
+Returns the number of bytes written.
+
+=cut
+
+sub create {
+ my $self = shift;
+
+ # write only if file does not yet exist
+ if ( -s $self->delegate ) {
+ return $self->throw_error(
+ $self->delegate . " already exists. cannot create()" );
+ }
+
+ return $self->_write;
+}
+
+=head2 read
+
+Slurp contents of file into buffer(). No check is performed as to whether
+the file exists, so call like:
+
+ $file->read if -s $file;
+
+=cut
+
+sub read {
+ my $self = shift;
+ $self->{buffer} = $self->delegate->slurp;
+ return $self;
+}
+
+=head2 update
+
+Just like create() only no check is made if the file exists prior to writing
+to it. Returns the number of bytes written.
+
+=cut
+
+sub update {
+ my $self = shift;
+ return $self->_write;
+}
+
+=head2 delete
+
+Remove the file from the filesystem.
+
+=cut
+
+sub delete {
+ my $self = shift;
+ return $self->delegate->remove;
+}
+
+sub _write {
+ my $self = shift;
+ my $dir = $self->delegate->dir;
+ $dir->mkpath;
+ my $fh = $self->delegate->openw();
+ print {$fh} $self->buffer;
+ $fh->close;
+ return -s $self->delegate;
+}
+
+1;
+
+__END__
+
+=head1 AUTHOR
+
+Peter Karman, C<< <perl at peknet.com> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-catalystx-crud at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CatalystX-CRUD>.
+I will be notified, and then you'll automatically be notified of progress on
+your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc CatalystX::CRUD
+
+You can also look for information at:
+
+=over 4
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/CatalystX-CRUD>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/CatalystX-CRUD>
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=CatalystX-CRUD>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/CatalystX-CRUD>
+
+=back
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2007 Peter Karman, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
Added: CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Object.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Object.pm (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Object.pm 2008-03-11 17:19:03 UTC (rev 7485)
@@ -0,0 +1,152 @@
+package CatalystX::CRUD::Object;
+use strict;
+use warnings;
+use base qw( CatalystX::CRUD Class::Accessor::Fast );
+use Carp;
+
+__PACKAGE__->mk_ro_accessors(qw( delegate ));
+
+our $VERSION = '0.26';
+
+=head1 NAME
+
+CatalystX::CRUD::Object - an instance returned from a CatalystX::CRUD::Model
+
+=head1 SYNOPSIS
+
+ package My::Object;
+ use base qw( CatalystX::CRUD::Object );
+
+ sub create { shift->delegate->save }
+ sub read { shift->delegate->load }
+ sub update { shift->delegate->save }
+ sub delete { shift->delegate->remove }
+
+ 1;
+
+=head1 DESCRIPTION
+
+A CatalystX::CRUD::Model returns instances of CatalystX::CRUD::Object.
+
+The assumption is that the Object knows how to manipulate the data it represents,
+typically by holding an instance of an ORM or other data model in the
+C<delegate> accessor, and calling methods on that instance.
+
+So, for example, a CatalystX::CRUD::Object::RDBO has a Rose::DB::Object instance,
+and calls its RDBO object's methods.
+
+The idea is to provide a common CRUD API for various backend storage systems.
+
+=head1 METHODS
+
+The following methods are provided.
+
+=cut
+
+=head2 new
+
+Generic constructor. I<args> may be a hash or hashref.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my $arg = ref( $_[0] ) eq 'HASH' ? $_[0] : {@_};
+ return $class->SUPER::new($arg);
+}
+
+=head2 delegate
+
+The delegate() accessor is a holder for the object instance that the CXCO instance
+has. A CXCO object "hasa" instance of another class in its delegate() slot. The
+delegate is the thing that does the actual work; the CXCO object just provides a container
+for the delegate to inhabit.
+
+Think of delegate as a noun, not a verb, as in "The United Nations delegate often
+slept here."
+
+
+=head1 REQUIRED METHODS
+
+A CXCO subclass needs to implement at least the following methods:
+
+=over
+
+=item create
+
+Write a new object to store.
+
+=item read
+
+Load a new object from store.
+
+=item update
+
+Write an existing object to store.
+
+=item delete
+
+Remove an existing object from store.
+
+=back
+
+=cut
+
+sub create { shift->throw_error("must implement create") }
+sub read { shift->throw_error("must implement read") }
+sub update { shift->throw_error("must implement update") }
+sub delete { shift->throw_error("must implement delete") }
+
+1;
+__END__
+
+=head1 AUTHOR
+
+Peter Karman, C<< <perl at peknet.com> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-catalystx-crud at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CatalystX-CRUD>.
+I will be notified, and then you'll automatically be notified of progress on
+your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc CatalystX::CRUD
+
+You can also look for information at:
+
+=over 4
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/CatalystX-CRUD>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/CatalystX-CRUD>
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=CatalystX-CRUD>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/CatalystX-CRUD>
+
+=back
+
+=head1 ACKNOWLEDGEMENTS
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2007 Peter Karman, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
Added: CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/REST.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/REST.pm (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/REST.pm 2008-03-11 17:19:03 UTC (rev 7485)
@@ -0,0 +1,245 @@
+package CatalystX::CRUD::REST;
+use strict;
+use warnings;
+use base qw( CatalystX::CRUD::Controller );
+
+use Carp;
+
+our $VERSION = '0.26';
+
+=head1 NAME
+
+CatalystX::CRUD::REST - REST-style controller for CRUD
+
+=head1 SYNOPSIS
+
+ # create a controller
+ package MyApp::Controller::Foo;
+ use strict;
+ use base qw( CatalystX::CRUD::REST );
+
+ __PACKAGE__->config(
+ form_class => 'MyForm::Foo',
+ init_form => 'init_with_foo',
+ init_object => 'foo_from_form',
+ default_template => 'path/to/foo/edit.tt',
+ model_name => 'Foo',
+ primary_key => 'id',
+ view_on_single_result => 0,
+ page_size => 50,
+ );
+
+ 1;
+
+ # now you can manage Foo objects using your MyForm::Foo form class
+ # with URIs at:
+ # foo/<pk>
+ # and use the HTTP method name to indicate the appropriate action.
+ # POST /foo -> create new record
+ # GET /foo -> list all records
+ # PUT /foo/<pk> -> update record
+ # DELETE /foo/<pk> -> delete record
+ # GET /foo/<pk> -> view record
+ # GET /foo/<pk>/edit_form -> edit record form
+ # GET /foo/create_form -> create record form
+
+
+=head1 DESCRIPTION
+
+CatalystX::CRUD::REST is a subclass of CatalystX::CRUD::Controller.
+Instead of calling RPC-style URIs, the REST API uses the HTTP method name
+to indicate the action to be taken.
+
+See CatalystX::CRUD::Controller for more details on configuration.
+
+The REST API is designed with identical configuration options as the RPC-style
+Controller API, so that you can simply change your @ISA chain and enable
+REST features for your application.
+
+=cut
+
+=head1 METHODS
+
+=head2 edit_form
+
+Acts just like edit() in base Controller class, but with a RESTful name.
+
+=head2 create_form
+
+Acts just like create() in base Controller class, but with a RESTful name.
+
+=cut
+
+sub create_form : Local {
+ my ( $self, $c ) = @_;
+ return $self->create($c);
+}
+
+sub edit_form : PathPart Chained('fetch') Args(0) {
+ my ( $self, $c ) = @_;
+ return $self->edit($c);
+}
+
+=head2 default
+
+Attribute: Private
+
+Calls the appropriate method based on the HTTP method name.
+
+=cut
+
+my %http_method_map = (
+ 'POST' => 'save',
+ 'PUT' => 'save',
+ 'DELETE' => 'rm',
+ 'GET' => 'view'
+);
+
+sub default : Path {
+ my ( $self, $c, @arg ) = @_;
+
+ my $oid = shift @arg;
+ my $rpc = shift @arg; # RPC compat
+ $c->log->debug("default OID: $oid") if $c->debug;
+
+ my $method = $self->req_method($c);
+ if ( !defined $oid && $method eq 'GET' ) {
+ $c->action( $c->action->namespace . '/list' );
+ return $self->list($c);
+ }
+
+ # everything else requires fetch()
+ $self->fetch( $c, $oid );
+
+ # what RPC-style method to call
+ my $to_call = defined($rpc) || $http_method_map{$method};
+ $c->log->debug("$method -> $to_call") if $c->debug;
+
+ # so auto-template-deduction works just like RPC style
+ $c->action( $c->action->namespace . '/' . $to_call );
+
+ return $self->can($to_call) ? $self->$to_call($c) : $self->view($c);
+}
+
+=head2 req_method( I<context> )
+
+Internal method. Returns the HTTP method name, allowing
+POST to serve as a tunnel when the C<_http_method> param
+is present. Since most browsers do not support PUT or DELETE
+HTTP methods, you can use the C<_http_method> param to tunnel
+the desired HTTP method and then POST instead.
+
+=cut
+
+sub req_method {
+ my ( $self, $c ) = @_;
+ if ( uc( $c->req->method ) eq 'POST' ) {
+ return exists $c->req->params->{'_http_method'}
+ ? uc(
+ ref $c->req->params->{'_http_method'}
+ ? $c->req->params->{'_http_method'}->[0]
+ : $c->req->params->{'_http_method'}
+ )
+ : 'POST';
+
+ }
+ return uc( $c->req->method );
+}
+
+=head2 edit( I<context> )
+
+Overrides base method to disable chaining.
+
+=cut
+
+sub edit {
+ my ( $self, $c ) = @_;
+ return $self->NEXT::edit($c);
+}
+
+=head2 view( I<context> )
+
+Overrides base method to disable chaining.
+
+=cut
+
+sub view {
+ my ( $self, $c ) = @_;
+ return $self->NEXT::view($c);
+}
+
+=head2 save( I<context> )
+
+Overrides base method to disable chaining.
+
+=cut
+
+sub save {
+ my ( $self, $c ) = @_;
+ return $self->NEXT::save($c);
+}
+
+=head2 rm( I<context> )
+
+Overrides base method to disable chaining.
+
+=cut
+
+sub rm {
+ my ( $self, $c ) = @_;
+ return $self->NEXT::rm($c);
+}
+
+1;
+
+__END__
+
+=head1 AUTHOR
+
+Peter Karman, C<< <perl at peknet.com> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-catalystx-crud at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CatalystX-CRUD>.
+I will be notified, and then you'll automatically be notified of progress on
+your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc CatalystX::CRUD
+
+You can also look for information at:
+
+=over 4
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/CatalystX-CRUD>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/CatalystX-CRUD>
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=CatalystX-CRUD>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/CatalystX-CRUD>
+
+=back
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2008 Peter Karman, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
Added: CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Tutorial.pod
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Tutorial.pod (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD/Tutorial.pod 2008-03-11 17:19:03 UTC (rev 7485)
@@ -0,0 +1,483 @@
+=pod
+
+=head1 NAME
+
+CatalystX::CRUD::Tutorial - step-by-step through CatalystX::CRUD example app
+
+=head1 OVERVIEW
+
+The goal of the CatalystX::CRUD project is to provide a thin glue between your existing
+data model code and your existing form processing code. The ideal CatalystX::CRUD application
+actually uses very little Catalyst-specific code. Instead, code independent of Catalyst does
+most of the heavy lifting. This design is intended to (a) make it easier
+to re-use your non-Catalyst code and (b) make your applications easier to test.
+
+This tutorial is intended for users of CatalystX::CRUD. Developers should also
+look at the CatalystX::CRUD API documentation. We will look
+at two of the CatalystX::CRUD implementations: the Rose::HTML::Objects
+controller (CatalystX::CRUD::Controller::RHTMLO) and the Rose::DB::Object model
+(CatalystX::CRUD::Model::RDBO). Note that these two modules are available on CPAN
+separately from the core CatalystX::CRUD package.
+
+
+=head2 Create a new Catalyst application
+
+ % catalyst.pl MyApp
+ ...
+ % cd MyApp
+
+Make a directory structure to accomodate the classes we'll be creating:
+
+ % mkdir lib/MyCRUD
+ % mkdir lib/MyCRUD/Album
+ % mkdir lib/MyCRUD/Song
+
+
+=head2 Create a database
+
+This tutorial will assume SQLite as the database, but any RDBO-supported database should work.
+You might need to tweek the SQL below to work with your particular database.
+
+ /* example SQL file to init db */
+
+ create table albums
+ (
+ id INTEGER primary key,
+ title varchar(128),
+ artist varchar(128)
+ );
+
+ create table songs
+ (
+ id INTEGER primary key,
+ title varchar(128),
+ artist varchar(128),
+ length varchar(16)
+ );
+
+ create table album_songs
+ (
+ album_id int not null references albums(id),
+ song_id int not null references songs(id)
+ );
+
+ insert into albums (title, artist) values ('Blonde on Blonde', 'Bob Dylan');
+ insert into songs (title, length) values ('Visions of Johanna', '8:00');
+
+Save the above into a file called C<mycrud.sql> and then create the SQLite database:
+
+ % sqlite3 mycrud.db < mycrud.sql
+
+Test your database by connecting and verifying the data:
+
+ % sqlite3 mycrud.db
+ SQLite version 3.1.3
+ Enter ".help" for instructions
+ sqlite> select * from songs;
+ 1|Visions of Johanna||8:00
+ sqlite> .quit
+
+Now you are ready to write some Perl.
+
+=head2 Create a base Rose::DB class
+
+We need a Rose::DB class to connect to our database.
+Save the following in C<lib/MyCRUD/DB.pm>:
+
+ package MyCRUD::DB;
+ use strict;
+ use warnings;
+ use base qw( Rose::DB );
+
+ __PACKAGE__->use_private_registry;
+
+ __PACKAGE__->register_db(
+ domain => __PACKAGE__->default_domain,
+ type => __PACKAGE__->default_type,
+ driver => 'sqlite',
+ database => $ENV{DB_PATH} || 'mycrud.db',
+ );
+
+ 1;
+
+Note that we can use the B<DB_PATH> environment variable as a convenience when we are not
+in the same directory as the database file. You could put this line in your
+C<MyApp.pm> file, just before you call MyApp->setup().
+
+ $ENV{DB_PATH} = __PACKAGE__->config->{db_path};
+
+and then in your myapp.yml (or equivalent) configuration file:
+
+ db_path: __HOME__/mycrud.db
+
+
+=head2 Create Rose::DB::Object classes
+
+The RDBO best practice is to create a base class that inherits from RDBO directly,
+and then create subclasses of your local base class. Following that convention,
+we'll create C<lib/MyCRUD/RDBO.pm> and then inherit from it:
+
+ package MyCRUD::RDBO;
+ use strict;
+ use warnings;
+ use base qw( Rose::DB::Object );
+
+ use MyCRUD::DB;
+
+ sub init_db {
+ my $class = shift;
+ return MyCRUD::DB->new_or_cached(@_, database => $ENV{DB_PATH});
+ }
+
+Note that the new_or_cached() method is relatively new to Rose::DB, so make sure you have
+the latest version from CPAN.
+
+Now we'll make the RDBO classes that correspond to our database. These go in
+C<lib/MyCRUD/Song.pm>, C<lib/MyCRUD/Album.pm> and C<lib/MyCRUD/AlbumSong.pm>,
+respectively.
+
+ package MyCRUD::Song;
+ use strict;
+ use base qw( MyCRUD::RDBO );
+
+ __PACKAGE__->meta->setup(
+ table => 'songs',
+ columns => [
+ id => {type => 'integer'},
+ title => {type => 'varchar', length => 128},
+ artist => {type => 'varchar', length => 128},
+ length => {type => 'varchar', length => 16},
+ ],
+ primary_key_columns => ['id'],
+ relationships => [
+ albums => {
+ map_class => 'CatRose::AlbumSong',
+ type => 'many to many',
+ },
+
+ ]
+ );
+ 1;
+
+
+ package MyCRUD::Album;
+ use strict;
+ use base qw( MyCRUD::RDBO );
+
+ __PACKAGE__->meta->setup(
+ table => 'albums',
+ columns => [
+ id => {type => 'integer'},
+ title => {type => 'varchar', length => 128},
+ artist => {type => 'varchar', length => 128},
+ ],
+ primary_key_columns => ['id'],
+ relationships => [
+ songs => {
+ map_class => 'CatRose::AlbumSong',
+ type => 'many to many',
+ },
+
+ ]
+ );
+ 1;
+
+
+ package MyCRUD::AlbumSong;
+ use strict;
+ use warnings;
+ use base qw( MyCRUD::RDBO );
+
+ __PACKAGE__->meta->setup(
+ table => 'album_songs',
+ columns => [
+ album_id => {type => 'integer', not_null => 1},
+ song_id => {type => 'integer', not_null => 1}
+ ],
+ foreign_keys => [
+ song => {class => 'CatRose::Song', key_columns => {song_id => 'id'}},
+ album => {class => 'CatRose::Album', key_columns => {album_id => 'id'}}
+ ]
+
+ );
+ 1;
+
+That's it for our data model. Now we will create our form classes.
+
+
+=head2 Create Rose::HTML::Form classes
+
+Just as with RDBO, best practice is to create a base form class that inherits from
+RHTMLO, and then subclass it for each form. Our base form class is C<lib/MyCRUD/Form.pm>.
+
+ package MyCRUD::Form;
+ use strict;
+ use warnings;
+ use base qw( Rose::HTML::Form );
+
+ 1;
+
+Now our application-specific classes in C<lib/MyCRUD/Album/Form.pm> and
+C<lib/MyCRUD/Song/Form.pm> respectively.
+
+ package MyCRUD::Album::Form;
+ use strict;
+ use warnings;
+ use base qw( MyCRUD::Form );
+ use Carp;
+
+ sub init_with_album {
+ my $self = shift;
+ my $album = shift;
+ if (!$album or !$album->isa('MyCRUD::Album')) {
+ croak "need MyCRUD::Album object";
+ }
+ return $self->init_with_object($album);
+ }
+
+ sub album_from_form {
+ my $self = shift;
+ my $album = shift;
+ if (!$album or !$album->isa('MyCRUD::Album')) {
+ croak "need MyCRUD::Album object";
+ }
+ $self->object_from_form($album);
+ return $album;
+ }
+
+ sub build_form {
+ my $self = shift;
+ $self->add_fields(
+ title => {
+ type => 'text',
+ size => 30,
+ required => 1,
+ label => 'Title',
+ maxlength => 128,
+ },
+ artist => {
+ type => 'text',
+ size => 30,
+ required => 1,
+ label => 'Artist',
+ maxlength => 128,
+ },
+ );
+ }
+
+ 1;
+
+
+ package MyCRUD::Song::Form;
+ use strict;
+ use warnings;
+ use base qw( MyCRUD::Form );
+ use Carp;
+
+ sub init_with_song {
+ my $self = shift;
+ my $song = shift;
+ if (!$song or !$song->isa('MyCRUD::Song'))
+ {
+ croak "need MyCRUD::Song object";
+ }
+ $self->init_with_object($song);
+ }
+
+ sub song_from_form {
+ my $self = shift;
+ my $song = shift;
+ if (!$song or !$song->isa('MyCRUD::Song')) {
+ croak "need MyCRUD::Song object";
+ }
+ $self->object_from_form($song);
+ return $song;
+ }
+
+ sub build_form {
+ my $self = shift;
+ $self->add_fields(
+ title => {
+ type => text',
+ size => 30,
+ required => 1,
+ label => 'Song Title',
+ maxlength => 128,
+ },
+ artist => {
+ type => 'text',
+ size => 30,
+ required => 1,
+ label => 'Artist',
+ maxlength => 128,
+ },
+ length => {
+ type => 'text',
+ size => 16,
+ maxlength => 16,
+ required => 1,
+ label => 'Song Length'
+ }
+ );
+ }
+
+ 1;
+
+
+=head2 Create Models
+
+So far we have not done anything with CatalystX::CRUD. Now we'll make some Model classes
+to glue our RDBO classes into the Catalyst MyApp application.
+
+Each RDBO class gets its own Model class: C<lib/MyApp/Model/Album.pm> and
+C<lib/MyApp/Model/Song.pm> respectively.
+
+ package MyApp::Model::Album;
+ use strict;
+ use warnings;
+ use base qw( CatalystX::CRUD::Model::RDBO );
+
+ __PACKAGE__->config(
+ name => 'MyCRUD::Album',
+ load_with => [qw( songs )],
+ );
+ 1;
+
+
+ package MyApp::Model::Song;
+ use strict;
+ use warnings;
+ use base qw( CatalystX::CRUD::Model::RDBO );
+
+ __PACKAGE__->config(
+ name => 'MyCRUD::Song',
+ load_with => [qw( albums )],
+ );
+ 1;
+
+We use C<load_with> in the configuation in order to pre-fetch related records
+with each RDBO object, but that is purely optional and will depend on the kind
+of application you are writing.
+
+Notice how little Model code is involved -- less than 10 lines per class.
+
+=head2 Create Controllers
+
+Now we'll make some Controllers. These act as the traffic cop in our application,
+coordinating our forms and models.
+
+Each RHTMLO class gets its own Controller class: C<lib/MyApp/Controller/Album.pm>
+and C<lib/MyApp/Controller/Song.pm> respectively.
+
+ package MyApp::Controller::Album;
+ use strict;
+ use warnings;
+ use base qw( CatalystX::CRUD::Controller::RHTMLO );
+
+ __PACKAGE__->config(
+ form_class => 'MyCRUD::Album::Form',
+ init_form => 'init_with_album',
+ init_object => 'album_from_form,
+ default_template => 'album/edit.tt', # you must create this!
+ model_name => 'Album',
+ primary_key => 'id',
+ view_on_single_result => 1,
+ );
+
+ 1;
+
+
+
+ package MyApp::Controller::Song;
+ use strict;
+ use warnings;
+ use base qw( CatalystX::CRUD::Controller::RHTMLO );
+
+ __PACKAGE__->config(
+ form_class => 'MyCRUD::Song::Form',
+ init_form => 'init_with_song',
+ init_object => 'song_from_form,
+ default_template => 'song/edit.tt', # you must create this!
+ model_name => 'Song',
+ primary_key => 'id',
+ view_on_single_result => 1,
+ );
+
+ 1;
+
+Hopefully most of the configuration values look familiar. You are mostly telling the Controller which form
+class and methods to use, and what Model to map the form to. See the
+L<CatalystX::CRUD::Controller> documentation for more details.
+
+
+=head2 The View
+
+CatalystX::CRUD is View-agnostic, so this tutorial will not cover the generation
+of templates. You can see examples of CatalystX::CRUD-friendly
+Template Toolkit templates in the
+Rose::DBx::Garden::Catalyst::Templates module on CPAN.
+
+=head2 Start Up
+
+Start up the application using the development server:
+
+ % perl script/myapp_server.pl
+
+Assuming you have created a View and some templates,
+you can now search, browse, create, read, update and delete all your Album
+and Song data.
+
+=head1 SEE ALSO
+
+The Rose::DBx::Garden::Catalyst package will generate all your RDBO, RHTMLO,
+and CatalystX::CRUD classes, along with spiffy AJAX-enhanced templates, based on
+just your database.
+
+=head1 AUTHOR
+
+Peter Karman, C<< <perl at peknet.com> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-catalystx-crud at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CatalystX-CRUD>.
+I will be notified, and then you'll automatically be notified of progress on
+your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc CatalystX::CRUD
+
+You can also look for information at:
+
+=over 4
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/CatalystX-CRUD>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/CatalystX-CRUD>
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=CatalystX-CRUD>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/CatalystX-CRUD>
+
+=back
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2007 Peter Karman, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
Added: CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD.pm (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/lib/CatalystX/CRUD.pm 2008-03-11 17:19:03 UTC (rev 7485)
@@ -0,0 +1,118 @@
+package CatalystX::CRUD;
+
+use warnings;
+use strict;
+use Catalyst::Exception;
+
+=head1 NAME
+
+CatalystX::CRUD - CRUD framework for Catalyst applications
+
+=head1 VERSION
+
+Version 0.01
+
+=cut
+
+our $VERSION = '0.26';
+
+=head1 DESCRIPTION
+
+This document is an overview of the CatalystX::CRUD framework and API.
+
+CatalystX::CRUD provides a simple and generic API for Catalyst CRUD applications.
+CatalystX::CRUD is agnostic with regard to data model and data input,
+instead providing a common API that different projects can implement for
+greater compatability with one another.
+
+The project was born out of a desire to make Rose::HTML::Objects easy to use
+with Rose::DB::Object and DBIx::Class ORMs, using the Catalyst::Controller::Rose
+project. However, any ORM could implement the CatalystX::CRUD::Model API,
+and any form management project could use the resulting CatalystX::CRUD::Model
+subclass.
+
+=head1 METHODS
+
+This class provides some basic methods that Model and Object subclasses inherit.
+
+=head2 has_errors( I<context> )
+
+Returns true if I<context> error() method has any errors set or if the
+C<error> value in stash() is set. Otherwise returns false (no errors).
+
+=cut
+
+sub has_errors {
+ my $self = shift;
+ my $c = shift or $self->throw_error("context object required");
+ return scalar( @{ $c->error } ) || $c->stash->{error} || 0;
+}
+
+=head2 throw_error( I<msg> )
+
+Throws Catalyst::Exception. Override to manage errors in some other way.
+
+NOTE that if in your subclass throw_error() is not fatal and instead
+returns a false a value, methods that call it will, be default, continue
+processing instead of returning. See fetch() for an example.
+
+=cut
+
+sub throw_error {
+ my $self = shift;
+ my $msg = shift || 'unknown error';
+ Catalyst::Exception->throw($msg);
+}
+
+=head1 AUTHOR
+
+Peter Karman, C<< <perl at peknet.com> >>
+
+=head1 BUGS
+
+Please report any bugs or feature requests to
+C<bug-catalystx-crud at rt.cpan.org>, or through the web interface at
+L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CatalystX-CRUD>.
+I will be notified, and then you'll automatically be notified of progress on
+your bug as I make changes.
+
+=head1 SUPPORT
+
+You can find documentation for this module with the perldoc command.
+
+ perldoc CatalystX::CRUD
+
+You can also look for information at:
+
+=over 4
+
+=item * AnnoCPAN: Annotated CPAN documentation
+
+L<http://annocpan.org/dist/CatalystX-CRUD>
+
+=item * CPAN Ratings
+
+L<http://cpanratings.perl.org/d/CatalystX-CRUD>
+
+=item * RT: CPAN's request tracker
+
+L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=CatalystX-CRUD>
+
+=item * Search CPAN
+
+L<http://search.cpan.org/dist/CatalystX-CRUD>
+
+=back
+
+=head1 ACKNOWLEDGEMENTS
+
+=head1 COPYRIGHT & LICENSE
+
+Copyright 2007 Peter Karman, all rights reserved.
+
+This program is free software; you can redistribute it and/or modify it
+under the same terms as Perl itself.
+
+=cut
+
+1; # End of CatalystX::CRUD
Added: CatalystX-CRUD/CatalystX-CRUD/trunk/t/00-load.t
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/t/00-load.t (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/t/00-load.t 2008-03-11 17:19:03 UTC (rev 7485)
@@ -0,0 +1,17 @@
+#!perl -T
+
+use Test::More tests => 9;
+
+BEGIN {
+ use_ok( 'CatalystX::CRUD' );
+ use_ok( 'CatalystX::CRUD::Model' );
+ use_ok( 'CatalystX::CRUD::Controller' );
+ use_ok( 'CatalystX::CRUD::REST' );
+ use_ok( 'CatalystX::CRUD::Object' );
+ use_ok( 'CatalystX::CRUD::Iterator' );
+ use_ok( 'CatalystX::CRUD::Model::File' );
+ use_ok( 'CatalystX::CRUD::Object::File' );
+ use_ok( 'CatalystX::CRUD::Iterator::File' );
+}
+
+diag( "Testing CatalystX::CRUD $CatalystX::CRUD::VERSION, Perl $], $^X" );
Added: CatalystX-CRUD/CatalystX-CRUD/trunk/t/01-file.t
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/t/01-file.t (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/t/01-file.t 2008-03-11 17:19:03 UTC (rev 7485)
@@ -0,0 +1,22 @@
+use Test::More tests => 6;
+
+BEGIN {
+ use lib qw( ../CatalystX-CRUD/lib );
+ use_ok('CatalystX::CRUD::Model::File');
+ use_ok('CatalystX::CRUD::Object::File');
+}
+
+use lib qw( t/lib );
+use Catalyst::Test 'MyApp';
+use Data::Dump qw( dump );
+
+ok( get('/foo'), "get /foo" );
+
+ok( my $response = request('/file/search'), "response for /file/search" );
+
+#dump( $response->headers );
+
+is( $response->headers->{status}, '302', "response was redirect" );
+
+ok( get('/autoload'), "get /autoload" );
+
Added: CatalystX-CRUD/CatalystX-CRUD/trunk/t/boilerplate.t
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/t/boilerplate.t (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/t/boilerplate.t 2008-03-11 17:19:03 UTC (rev 7485)
@@ -0,0 +1,48 @@
+#!perl -T
+
+use strict;
+use warnings;
+use Test::More tests => 3;
+
+sub not_in_file_ok {
+ my ($filename, %regex) = @_;
+ open my $fh, "<", $filename
+ or die "couldn't open $filename for reading: $!";
+
+ my %violated;
+
+ while (my $line = <$fh>) {
+ while (my ($desc, $regex) = each %regex) {
+ if ($line =~ $regex) {
+ push @{$violated{$desc}||=[]}, $.;
+ }
+ }
+ }
+
+ if (%violated) {
+ fail("$filename contains boilerplate text");
+ diag "$_ appears on lines @{$violated{$_}}" for keys %violated;
+ } else {
+ pass("$filename contains no boilerplate text");
+ }
+}
+
+not_in_file_ok(README =>
+ "The README is used..." => qr/The README is used/,
+ "'version information here'" => qr/to provide version information/,
+);
+
+not_in_file_ok(Changes =>
+ "placeholder date/time" => qr(Date/time)
+);
+
+sub module_boilerplate_ok {
+ my ($module) = @_;
+ not_in_file_ok($module =>
+ 'the great new $MODULENAME' => qr/ - The great new /,
+ 'boilerplate description' => qr/Quick summary of what the module/,
+ 'stub function definition' => qr/function[12]/,
+ );
+}
+
+module_boilerplate_ok('lib/CatalystX/CRUD.pm');
Added: CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp/Controller/File.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp/Controller/File.pm (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp/Controller/File.pm 2008-03-11 17:19:03 UTC (rev 7485)
@@ -0,0 +1,47 @@
+package MyApp::Controller::File;
+use strict;
+use base qw( CatalystX::CRUD::Controller );
+use Carp;
+use Data::Dump qw( dump );
+use File::Temp;
+
+# test the view_on_single_result method
+# search for a file where we know there is only one
+# and then check for a redirect response code
+# NOTE we have to fake up the primary_key method
+# to just return the file path (the unique id)
+# and the form class to just use a dummy
+
+{
+
+ package NoForm;
+ sub new { return bless( {}, shift(@_) ); }
+}
+
+__PACKAGE__->config(
+ primary_key => 'absolute',
+ form_class => 'NoForm',
+ model_name => 'File',
+);
+
+sub do_search {
+
+ my ( $self, $c, @arg ) = @_;
+
+ $self->config->{view_on_single_result} = 1;
+
+ my $tmpf = File::Temp->new;
+
+ my $file = $c->model( $self->model_name )->new_object( file => $tmpf->filename );
+
+ if ( my $uri = $self->view_on_single_result( $c, [$file] ) ) {
+ $c->response->redirect($uri);
+ return;
+ }
+
+ $self->throw_error("view_on_single_result failed");
+
+}
+
+
+1;
Added: CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp/File.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp/File.pm (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp/File.pm 2008-03-11 17:19:03 UTC (rev 7485)
@@ -0,0 +1,5 @@
+package MyApp::File;
+use base qw( CatalystX::CRUD::Object::File );
+
+1;
+
Added: CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp/Model/File.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp/Model/File.pm (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp/Model/File.pm 2008-03-11 17:19:03 UTC (rev 7485)
@@ -0,0 +1,7 @@
+package MyApp::Model::File;
+use base qw( CatalystX::CRUD::Model::File );
+use MyApp::File;
+__PACKAGE__->config->{object_class} = 'MyApp::File';
+
+1;
+
Added: CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp.pm
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp.pm (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/t/lib/MyApp.pm 2008-03-11 17:19:03 UTC (rev 7485)
@@ -0,0 +1,104 @@
+package MyApp;
+use Catalyst::Runtime '5.70';
+use Catalyst;
+use Carp;
+use Data::Dump qw( dump );
+use File::Temp;
+
+our $VERSION = '0.02';
+
+__PACKAGE__->setup();
+
+sub foo : Local {
+
+ my ( $self, $c, @arg ) = @_;
+
+ my $tempf = File::Temp->new;
+
+ # have to set inc_path() after we create our first file
+ # so that we know where the temp dir is.
+
+ #carp "inc_path: " . dump $c->model('File')->inc_path;
+
+ my $file = $c->model('File')->new_object( file => $tempf->filename );
+
+ #carp dump $file;
+
+ $file->buffer('hello world');
+
+ $file->create;
+
+ my $filename = $file->basename;
+
+ #carp "filename = $filename";
+
+ # set inc_path now that we know dir
+ $c->model('File')->config->{inc_path} = [ $file->dir ];
+
+ #carp "inc_path: " . dump $c->model('File')->inc_path;
+
+ $file = $c->model('File')->fetch( file => $filename );
+
+ #carp dump $file;
+
+ $file->read;
+
+ if ( $file->buffer ne 'hello world' ) {
+ croak "bad read";
+ }
+
+ $file->buffer('change the text');
+
+ #carp dump $file;
+
+ $file->update;
+
+ $file = $c->model('File')->fetch( file => $filename );
+
+ $c->res->body("foo is a-ok");
+
+}
+
+sub autoload : Local {
+ my ( $self, $c ) = @_;
+
+ my $tempf = File::Temp->new;
+
+ # have to set inc_path() after we create our first file
+ # so that we know where the temp dir is.
+
+ my $file = $c->model('File')->new_object( file => $tempf->filename );
+
+ #warn "testing basename on $file";
+
+ # test that calling $file->foo actually calls foo()
+ # on $file->delegate and not $file itself
+ eval { $file->basename };
+ if ($@) {
+ warn "failed to call ->basename on $file: $@";
+ return;
+ }
+
+ unless ( $file->can('basename') ) {
+ warn "can't can(basename) but can ->basename";
+ return;
+ }
+
+ # test that we can still call read() and can(read) on the parent object
+ eval { $file->read };
+ if ($@) {
+ warn "$file cannot read() - $@ $!";
+ return;
+ }
+
+ eval { $file->can('read') };
+ if ($@) {
+ warn "$file cannot can(read) - $@ $!";
+ return;
+ }
+
+ $c->res->body("autoload is a-ok");
+
+}
+
+1;
Added: CatalystX-CRUD/CatalystX-CRUD/trunk/t/pod-coverage.t
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/t/pod-coverage.t (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/t/pod-coverage.t 2008-03-11 17:19:03 UTC (rev 7485)
@@ -0,0 +1,6 @@
+#!perl -T
+
+use Test::More;
+eval "use Test::Pod::Coverage 1.04";
+plan skip_all => "Test::Pod::Coverage 1.04 required for testing POD coverage" if $@;
+all_pod_coverage_ok();
Added: CatalystX-CRUD/CatalystX-CRUD/trunk/t/pod.t
===================================================================
--- CatalystX-CRUD/CatalystX-CRUD/trunk/t/pod.t (rev 0)
+++ CatalystX-CRUD/CatalystX-CRUD/trunk/t/pod.t 2008-03-11 17:19:03 UTC (rev 7485)
@@ -0,0 +1,6 @@
+#!perl -T
+
+use Test::More;
+eval "use Test::Pod 1.14";
+plan skip_all => "Test::Pod 1.14 required for testing POD" if $@;
+all_pod_files_ok();
More information about the Catalyst-commits
mailing list