Which Perl module should I use to generate a validating CRUD webform? - perl

Has anyone successfully used something like DBIx::Class::WebForm or CatalystX-CRUD to automagically build a self-validating webform from a database table?
I'm imagining a module that reads a database table schema, reads the constraints for each column, and generates some abstract representation of a webform, with fields for error messages, etc. I'm using Catalyst and Plack with a big existing codebase.
I don't want to code up an HTML webform, nor any validation logic. I'm aiming to write as little code as possible, in the style of Ruby on Rails. Which Perl module is best for this?
UPDATE: I've solved the webform side with HTML::FormFu, but it's still clunky mapping the form inputs onto the database, e.g. date_start and date_end both relate to the 'created' column, and comment should match using 'LIKE %foo%', etc. Where's the 'DBICFu'?
UPDATE: This is for a web application, the webform should not look like a database table. I'm not looking for a database management tool.

You can use use HTML::FormHandler::Moose and HTML::FormHandler::Model::DBIC and get some nice forms.
As a simple example:
The form definition:
package MyStats::Form::Datetime ;
use HTML::FormHandler::Moose ;
extends 'HTML::FormHandler::Model::DBIC' ;
use Date::Calc qw(Today_and_Now) ;
has_field 'datetimeid' => ( label => 'ID' ) ;
has_field 'datetime' => ( type => 'Text',
apply => [ { transform => \&transform_dt } ] ,
deflation => \&deflation_dt ,
required => 1 ) ;
has_field 'submit' => ( type => 'Submit' ,
value => 'Speichern' ) ;
# These are the fields of the table datetime
sub transform_dt {
my ( $dt ) = #_ ;
my #d = ( $dt =~ m/(\d{1,2})\.(\d{1,2})\.(\d{4})\s+(\d{1,2}):(\d{1,2})/ ) ;
return sprintf( '%04d-%02d-%02d %02d:%02d:00' , #d[2,1,0,3,4] ) ;
}
sub deflation_dt {
my ( $dt ) = #_ ;
my #d = ( $dt =~ m/(\d{4})-(\d{2})-(\d{2})\s+(\d{1,2}):(\d{1,2})/ ) ;
if( ! #d ) {
#d = Today_and_Now() ;
}
return sprintf( '%02d.%02d.%04d %02d:%02d:00' , #d[2,1,0,3,4] ) ;
}
1 ;
And the usage in a controller:
package MyStats::Controller::Datetime ;
use Moose ;
use namespace::autoclean ;
BEGIN { extends 'Catalyst::Controller' ; }
use MyStats::Form::Datetime ;
has 'form' => ( isa => 'MyStats::Form::Datetime' ,
is => 'rw' ,
lazy => 1 ,
default => \&new_datetime_form ) ;
sub new_datetime_form {
MyStats::Form::Datetime->new( css_class => 'datetimeform' ,
name => 'datetimeform' ) ;
}
...
sub add :Local :Args(0) {
my ( $self , $ctx ) = #_ ;
my $data = $ctx->model( 'MyStatsDB::Datetime' )->new_result( {} ) ;
$ctx->stash( template => 'datetime/add.tt2' ,
form => $self->form ) ;
$ctx->bread_crumb( { name => 'Datum/Zeit eingeben' ,
location => '/datetime/add' } ) ;
$ctx->req->param( 'datetimeid' , undef ) if $ctx->req->param( 'datetimeid' ) ;
return unless $self->form->process( item => $data ,
params => $ctx->req->params ) ;
$ctx->flash( message => 'Neuer Datensatz ' . $data->datetimeid .
' angelegt.' ,
id_add => $data->datetimeid ) ;
$ctx->res->redirect( $ctx->uri_for( '/datetime' ) ) ;
}
...
__PACKAGE__->meta->make_immutable ;
1 ;
Works good.

I've used HTML::FormHandler to generate forms for me in this fashion. It needs some tweaking, but it does 90% of the work for you. Separately DBIx::Class offers a similar tool.

There are a number of crud options on the Catalyst wiki.
It sounds like AutoCrud would fit your needs.

Related

Perl Gtk2 CellRendererCombo: get selected item index

I have Gtk2::TreeView, some of columns are using CellRendererCombo. I have everything work ok, except of I can't get integer index of selected item in CellRendererCombo. Not a text, but the integer value.
As a workaround, it could be useful to associate somehow a hash with combo_model, but I don't know how.
Could somebody help me? Trying and googling for a couple of days already.
Here's the code:
#!/usr/bin/perl
package uform;
use utf8;
use warnings;
use strict;
use Gtk2 -init;
use Glib qw/TRUE FALSE/;
use Glib ':constants';
use Data::Dumper;
use constant col0 => 0;
use constant col1 => 1;
use constant col2 => 2;
use constant colC => 3;
binmode(STDOUT,':utf8');
my $model; my $treeview; my #attr_models;
sub create_window ($$) {
my ($width,$height)=(shift,shift);
my $window = Gtk2::Window->new( "toplevel" );
$window->signal_connect( "destroy", sub { Gtk2->main_quit(); } );
$window->set_default_size($width,$height);
my $vbox = Gtk2::VBox->new( 0, 5 );
$model = Gtk2::ListStore->new(
"Gtk2::Gdk::Pixbuf", #0 pic
"Glib::String", #1 product
"Glib::String", #2 attr
"Gtk2::ListStore" #combo values list
);
#sample_data
#some combo lists
foreach my $d (
[qw(fast medium slow)],
[qw(greay orange black white rainbow)],
[qw(fat with_wholes molded)],
[qw(long short jeans)]
)
{
my $cmodel = Gtk2::ListStore->new('Glib::String');
foreach my $str (#$d) {$cmodel->set($cmodel->append,0,$str);}
push #attr_models,$cmodel;
}
#some pixbufs to play with
my $pixbuf2 = Gtk2::Button->new->render_icon ('gtk-info', 'large-toolbar');
#add some rows
my #data = (
[$pixbuf2,'Shirt',1,$attr_models[0]],
[$pixbuf2,'Pants',0,$attr_models[0]],
[$pixbuf2,'Cheese',2,$attr_models[1]],
[$pixbuf2,'Cola',1,$attr_models[2]],
[$pixbuf2,'Laptop',0,$attr_models[3]]
);
foreach my $st(#data) {
$st->[2]=$st->[3]->get($st->[3]->iter_nth_child(undef,$st->[2]), 0);
$model->set( $model->append,
0, $st->[0],
1, $st->[1],
2, $st->[2],
3, $st->[3],
);
}
#Column0 setup
my $combo_model0 = Gtk2::ListStore->new( 'Gtk2::Gdk::Pixbuf' );
my $renderer_0 = Gtk2::CellRendererPixbuf->new;
my $column_0 = Gtk2::TreeViewColumn->new_with_attributes(
"Pic",
$renderer_0,
pixbuf => col0
);
#Column1 setup
my $renderer_1 = Gtk2::CellRendererText->new;
$renderer_1->set( editable => FALSE );
my $column_1 = Gtk2::TreeViewColumn->new_with_attributes(
"Product",
$renderer_1,
text => col1
);
#Column2 setup
my $renderer_2 = Gtk2::CellRendererCombo->new;
$renderer_2->set(
editable => TRUE,
text_column => 0,
has_entry => FALSE
);
$renderer_2->signal_connect (changed => sub {
my ($renderer, $str, $iter)=#_;
print Dumper (#_) . "\n";
}
);
$renderer_2->signal_connect (edited =>
sub {
my ($renderer, $text_path, $new_text) = #_;
my $combo_model = $renderer->get("model");
$model->set ($model->get_iter_from_string ($text_path), col2, $new_text);
}
);
my $column_2 = Gtk2::TreeViewColumn->new_with_attributes(
"Attr",
$renderer_2,
text => col2,
model => colC
);
# main program starts
$treeview = Gtk2::TreeView->new( $model );
$treeview->get_selection->set_mode ('single');
$treeview->set_rules_hint( TRUE );
$treeview->append_column( $column_0 );
$treeview->append_column( $column_1 );
$treeview->append_column( $column_2 );
my $sw = Gtk2::ScrolledWindow->new( undef, undef );
$sw->set_shadow_type( "etched-in" );
$sw->set_policy( "never", "always" );
$sw->add( $treeview );
$vbox->pack_start( $sw, 1, 1, 0 );
$window->add( $vbox );
$window->show_all;
}
So, looks like there isn't any direct answer for this question.
As a workaround, you may create array of hashes. Each element corresponds to one TreeView's row and have e.g. fields like 'combo_hash' and 'current_index'.
'current_index' is self-explained, 'combo_hash' is array which consists of hashes with some fields like 'text' and e.g. 'index' (or other id).
On CellRendererCombo's 'edited' signal you get current TreeView's index by $treeview->get_selection()->get_selected_rows()->get_indices() (it's simple int), and search for selected in CellRendererCombo's 'text' field through 'combo_hash' array. Don't forget to store finded 'index' to 'current_index'.
This workaround allows non-unique text in different TreeView's rows, but can't handle non-unique text in one CellRendererCombo's ListStore.
Another workaround is to inherite subclass from CellRenderer and embed ComboBox, which provides simple integer index. Looks better and have no limitations by non-unique data, but if array of hashes is unavoidable by design (you need to store lots of other info not visible in TreeView), first workaround should be more relevant.

Perl: passing two argument through a config file

What should I do if I have to pass two values for same variable? Does following syntax work ?
sub get_db { return "database_name", "new_database"};
It does not pass both the value
The simplest way to return several values from a sub is a list: (NOTE - none of the following code has been tested)
return ($db_name, $new_db, $table, $rows)
...
my ($database_name, $database, $table_name, $entry_count) = get_db();
but that's easy to mess up - if you have a missmatch between the number of things returned and received something silently becomes undef. Likewise if the order of returned values is wrong, you are going to introduce a subtle bug.
Slightly better is to return a hashref;
....
my $return_values = { NAME => $db_name , DB => $new_db , TABLE => $table } ;
# add the number of rows and return it
$return_values->{ COUNT } = $rows ;
return $return_values ;
...
...
my $db_stuff = get_db();
for my $i (1 .. $db_stuff->{COUNT}) {
...
Better again is to learn a little OO and return an object. Moo is one of many options - it would look something like this:
Package DBstuff;
has name, is => ro ;
has db, is => ro ;
has table, is => ro ;
has count, is => rw ;
1;
... in another file ...
my $db_stuff = DBstuff->new(
name => $name ,
db => $db ,
table => $table,
);
# Add rows and return
$db_stuff->count( $rows );
return $db_stuff ;
...
...
my $db_data = get_db();
for my $i (1 .. $db_data->count) {
...
There is also a module called Object::Result which would almost certainly be overkill but whether you use it or not, I'd like to recommend the RATIONAL section of that module's documentation which covers the issue of returning several things from a sub in more depth.
Perl allows to return an array with multiple values, e.g.
sub get_db { return ["database_name", "new_database"] };

How to add multiple custom fields to a wp_query in a shortcode?

In a shortcode I can limit wp_query results by custom field values.
Example:
[my-shortcode meta_key=my-custom-field meta_value=100,200 meta_compare='IN']
And obviously it's possible to use multiple custom fields in a wp_query like WP_Query#Custom_Field_Parameters
But how can I use multiple custom fields in my shortcode? At the moment I do pass all the shortcode parameters with $atts.
On of a few different solutions might be to use a JSON encoded format for the meta values. Note that this isn't exactly user-friendly, but certainly would accomplish what you want.
You would of course need to generate the json encoded values first and ensure they are in the proper format. One way of doing that is just using PHP's built in functions:
// Set up your array of values, then json_encode them with PHP
$values = array(
array('key' => 'my_key',
'value' => 'my_value',
'operator' => 'IN'
),
array('key' => 'other_key',
'value' => 'other_value',
)
);
echo json_encode($values);
// outputs: [{"key":"my_key","value":"my_value","operator":"IN"},{"key":"other_key","value":"other_value"}]
Example usage in the shortcode:
[my-shortcode meta='[{"key":"my_key","value":"my_value","operator":"IN"},{"key":"other_key","value":"other_value"}]']
Which then you would parse out in your shortcode function, something like so:
function my_shortcode($atts ) {
$meta = $atts['meta'];
// decode it "quietly" so no errors thrown
$meta = #json_decode( $meta );
// check if $meta set in case it wasn't set or json encoded proper
if ( $meta && is_array( $meta ) ) {
foreach($meta AS $m) {
$key = $m->key;
$value = $m->value;
$op = ( ! empty($m->operator) ) ? $m->operator : '';
// put key, value, op into your meta query here....
}
}
}
Alternate Method
Another method would be to cause your shortcode to accept an arbitrary number of them, with matching numerical indexes, like so:
[my-shortcode meta-key1="my_key" meta-value1="my_value" meta-op1="IN
meta-key2="other_key" meta-value2="other_value"]
Then, in your shortcode function, "watch" for these values and glue them up yourself:
function my_shortcode( $atts ) {
foreach( $atts AS $name => $value ) {
if ( stripos($name, 'meta-key') === 0 ) {
$id = str_ireplace('meta-key', '', $name);
$key = $value;
$value = (isset($atts['meta-value' . $id])) ? $atts['meta-value' . $id] : '';
$op = (isset($atts['meta-op' . $id])) ? $atts['meta-op' . $id] : '';
// use $key, $value, and $op as needed in your meta query
}
}
}

How do I add more than one over method to a mojolicious route?

I have the following code:
$r->find('user')->via('post')->over(authenticated => 1);
Given that route I can get to the user route passing through the authenticated check
that is setup using Mojolicious::Plugin::Authentication.
I want add another 'over' to that route.
$r->find('user')->via('post')->over(authenticated => 1)->over(access => 1);
That appears to override authenticated 'over' though.
I tried breaking up the routes with names like:
my $auth = $r->route('/')->over(authenticated => 1)
->name('Authenticated Route');
$access = $auth->route('/user')->over(access => 1)->name('USER_ACCESS');
That didn't work at all though. Neither of the 'over's are being accessed.
My routes are things like /user, /item, set up using MojoX::JSON::RPC::Service.
So, I don't have things like /user/:id to set up sub routes.( not sure that matters )
All routes are like /user, sent with parameters.
I've got a condition like:
$r->add_condition(
access => sub {
# do some stuff
},
);
that is the 'access' in $r->route('/user')->over(access => 1);
In short, the routes work fine when using:
$r->find('user')->via('post')->over(authenticated => 1);
But I'm unable to add a 2nd route.
So, what am I missing in setting up these routes with multiple conditions?
Is it possible to add multiple conditions to a single route /route_name?
You can just use both conditions in over like in this test:
use Mojolicious::Lite;
# dummy conditions storing their name and argument in the stash
for my $name (qw(foo bar)) {
app->routes->add_condition($name => sub {
my ($route, $controller, $to, #args) = #_;
$controller->stash($name => $args[0]);
});
}
# simple foo and bar dump action
sub dump {
my $self = shift;
$self->render_text(join ' ' => map {$self->stash($_)} qw(foo bar));
}
# traditional route with multiple 'over'
app->routes->get('/frst')->over(foo => 'yo', bar => 'works')->to(cb => \&dump);
# lite route with multiple 'over'
get '/scnd' => (foo => 'hey', bar => 'cool') => \&dump;
# test the lite app above
use Test::More tests => 4;
use Test::Mojo;
my $t = Test::Mojo->new;
# test first route
$t->get_ok('/frst')->content_is('yo works');
$t->get_ok('/scnd')->content_is('hey cool');
__END__
1..4
ok 1 - get /frst
ok 2 - exact match for content
ok 3 - get /scnd
ok 4 - exact match for content
Works fine here with Mojolicious 3.38 on perl 5.12.1 - #DavidO is right, maybe bridges can do the job better. :)
In my case I use two under methods:
$r = $app->routes;
$guest = $r->under->to( 'auth#check_level' );
$user = $r->under->to( 'auth#check_level', { required_level => 100 } );
$admin = $r->under->to( 'auth#check_level', { required_level => 200 } );
$guest->get( '/' )->to( 'main#index' );
$user->get( '/user' )->to( 'user#show' );
$super_admin = $admin->under->to( 'manage#check_level', { super_admin => 100 } );
$super_admin->get( '/delete_everything' )->to( 'system#shutdown' );
In this example when any of routes match some under will be called
'/' -> auth#check_level -> main_index
'/user' -> auth#check_level { required_level => 100 } -> 'user#show'
'/delete_everything' -> auth#check_level { required_level => 200 } -> 'manage#check_level', { super_admin => 100 } -> 'system#shutdown'
As you can see before target action in your controller will be run another action called: auth#check_level and manage#check_level
In each those extra actions you just compare stash->{ required_level } with session->{ required_level } you have set when authorize user
package YourApp::Controller::Manage;
sub check_level {
my $self = shift;
my $user_have = $self->session->{ required_level };
my $we_require = $self->stash->{ required_level };
# 'system#shutdown' will be called if user has required level
return 1 if $user_have >= $we_require;
$self->redirect_to( '/you_have_no_access_rights' );
return 0; #This route will not match. 'system#shutdown' will not be called
}
PS Of course I may use cb or just CODEREF which are "close same" to controller action:
$r->under({ cb => \&YourApp::Controller::auth::check_level });
$r->under( \&YourApp::Controller::auth::check_level ); # "same"
But I prefer ->to( 'controller#action' ) syntax. It looks much better
What if we use this approach?
# register condition
$r->add_condition(
chain => sub {
my ($route, $controller, $captures, $checkers) = #_;
for my $checker (#$checkers) {
return 0 unless $checker->($route, $controller, $captures);
}
return 1;
},
);
# ...
# example of using
$r->get('/')->over(chain => [\&checker1, \&checker2])->to(cb => \&foo)->name('bar');

how to query eXist using XPath?

I decided to use eXist as a database for an application that I am writing in Perl and
I am experimenting with it. The problem is that I have stored a .xml document with the following structure
<foo-bar00>
<perfdata datum="GigabitEthernet3_0_18">
<cli cmd="whatsup" detail="GigabitEthernet3/0/18" find="" given="">
<input_rate>3</input_rate>
<output_rate>3</output_rate>
</cli>
</perfdata>
<timeline>2011-5-23T11:15:33</timeline>
</foo-bar00>
and it is located in the "/db/LAB/foo-bar00/2011/5/23/11_15_33.xml" collection.
I can successfully query it, like
my $xquery = 'doc("/db/LAB/foo-bar00/2011/5/23/11_15_33.xml")' ;
or $xquery can be equal to
= doc("/db/LAB/foo-bar00/2011/5/23/11_15_33.xml")/foo-bar00/perfdata/cli/data(output_rate)
or
= doc("/db/LAB/foo-bar00/2011/5/23/11_15_33.xml")/foo-bar00/data(timeline)
my ($rc1, $set) = $eXist->executeQuery($xquery) ;
my ($rc2, $count) = $eXist->numberOfResults($set) ;
my ($rc3, #data) = $eXist->retrieveResults($set) ;
$eXist->releaseResultSet($set) ;
print Dumper(#data) ;
And the result is :
$VAR1 = {
'hitCount' => 1,
'foo-bar00' => {
'perfdata' => {
'cli' => {
'given' => '',
'detail' => 'GigabitEthernet3/0/18',
'input_rate' => '3',
'cmd' => 'whatsup',
'output_rate' => '3',
'find' => ''
},
'datum' => 'GigabitEthernet3_0_18'
},
'timeline' => '2011-5-23T11:15:33'
}
};
---> Given that I know the xml document that I want to retrieve info from.
---> Given that I want to retrieve the timeline information.
When I am writing :
my $db_xml_doc = "/db/LAB/foo-bar00/2011/5/23/11_15_33.xml" ;
my ($db_rc, $db_datum) = $eXist->queryXPath("/foo-bar00/timeline", $db_xml_doc, "") ;
print Dumper($db_datum) ;
The result is :
$VAR1 = {
'hash' => 1717362942,
'id' => 3,
'results' => [
{
'node_id' => '1.2',
'document' => '/db/LAB/foo-bar00/2011/5/23/11_15_33.xml'
}
]
};
The question is : How can I retrieve the "timeline" info ? Seems that the "node_id" variable (=1.2) can points to the "timeline" info, but how can I use it ?
Thank you.
use XML::LibXML qw( );
my $parser = XML::LibXML->new();
my $doc = $parser->parse_file('a.xml');
my $root = $doc->documentElement();
my ($timeline) = $root->findnodes('timeline');
if ($timeline) {
print("Exists: ", $timeline->textContent(), "\n");
}
or
my ($timeline) = $root->findnodes('timeline/text()');
if ($timeline) {
print("Exists: ", $timeline->getValue(), "\n");
}
I could have used /foo-bar00/timeline instead of timeline, but I didn't see the need.
Don't know if you're still interested, but you could either retrieve the doc as DOM and apply an xquery to the DOM, or, probably better, only pull out the info you want in the query that you submit to the server.
Something like this:
for $p in doc("/db/LAB/foo-bar00/2011/5/23/11_15_33.xml")//output_rate
return
<vlaue>$p</value>