represent allowed status transitions graph in Perl - perl

There is something like status changes check logic in our app.
Currently checking is being handled by ugly if statement
I want to replace it by transition matrix:
my %allowed_status_changes = (
1 => (2,5),
2 => (1,2,3,4,5),
3 => (4,2),
4 => (3,2),
5 => (),
);
my $is_allowed_transition =
$submitted_status ~~ $allowed_status_changes {$original_status};
if ($prerequestsites && !$is_allowed_transition) {
return;
}
certain transitions can be allowed only on additional condition, therefore I will need something like
2 => (
(target => 1)
(target => 2, condition => $some_condition)
(target => (3,4), condition => $other_condition),
(target => 5)
),
(in my opinion it is too long)
What structure would you use in this situation if you should focus on readability and maintainability?
How you will parse it to check if transition is allowed?

If the conditions are very prevalent (e.g. almost every allowed transition has them) then your latter structure is perfectly fine, other than your syntax error of representing a hashref with "()" instead of "{}".
If the conditions are rare, I'd suggest going with #1, augmented by optional constructs similar to your #2.
Please note that readability of checking code is IMHO very clear though voluminous and not very idiomatic.
OTOH, maintainability of the matrix is high - you have terse yet readable syntax from #1 where no conditions are needed and a clear though longer syntax for conditions which is flexible enough for many conditions per many settings like your #2.
my %allowed_status_changes = (
1 => [2,5],
2 => [1,5,{targets=>[2], conditions=>[$some_condition]}
,{targets=>[3,4], conditions=>[$other_condition, $more_cond]}]
3 => [4,2],
4 => [3,2],
5 => [],
);
sub is_allowed_transition {
my ($submitted_status, $original_status ) = #_;
foreach my $alowed_status (#$allowed_status_changes{$original_status}) {
return 1 if !ref $alowed_status && $alowed_status == $submitted_status;
if (ref $alowed_status) {
foreach my $target (#$alowed_status{targets}) {
foreach my $condition (#$alowed_status{conditions}) {
return 1 if check_condition($submitted_status
, $original_status, $condition);
}
}
}
}
return 0;
}
if ($prerequestsites
&& !$is_allowed_transition($submitted_status, $original_status )) {
return;
}

Although I agree with DVK for the most part, I have to say, once you start delving into arrays of arrays of hashes, you're reaching a code complexity level that is hard to maintain without much spinning of heads and bugs.
At this point, I'd probably reach for an object and a class, for a bit of syntactic sugar.
my $transitions = TransitionGraph->new();
$transition->add( 1, { targets => [ 2, 5 ] });
$transition->add( 2, { targets => [ 1, 5 ] });
$transition->add( 2, { targets => [ 2 ], conditions => [ $some_condition ] });
$transition->add( 2, { targets => [ 3, 4 ], conditions => [ $other_condition, $more_cond ]});
$transition->add( 3, { targets => [4,2] } );
$transition->add( 4, { targets => [3,2] } );
$transition->add( 5, { targets => [] } );
if( $transition->allowed( 1 , 3 )){
}
Class implementation is up to the user, but I'd use Moose.
The primary benefits of this is you're encapsulating how the state graph works so you can Just Use it and worry about how the graph works seperate from where its used.
nb. in the above proposed API, add() creates a new record if one does not exist, and updates that record if it does exist. This turned out to be simpler than having "upgrade" methods or "get this item and then modify it" techniques.
Internally, it could do this, or something like it:
sub add {
my ( $self , $input_state, $rules ) = #_;
my $state;
if ( $self->has_state( $input_state ) ) {
$state = $self->get_state( $input_state );
} else {
$state = TransitionGraphState->new( source_id => $input_state );
$self->add_state( $input_state, $state );
}
my $targets = delete $rules{targets};
for my $target ( #$targets ) {
$state->add_target( $target, $rules );
}
return $self;
}
sub allowed {
my ( $self, $from, $to ) = #_;
if ( not $self->has_state( $from ) ){
croak "NO source state $from in transition graph";
}
my $state = $self->get_state( $from );
return $state->allowed_to( $to );
}
This also has the cool perk of not requiring one particular code set to work on the sub-nodes, you can create seperate instances with their own behaviour just in case you want one source state to be treated differently.
$transition->add_state( 2, $some_other_class_wich_works_like_transitiongraphstate );
Hope this is helpful =).

There is nothing wrong with the second form. You are not going to be able to get around the fact that you must encode the state machine somewhere. In fact, I think having the entire machine encoded in one place like that is far easier to understand that something with too many layers of abstraction where you need to look in n different places to understand the flow of the machine.

Related

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 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 do I access a specific return value from the CDBI::Search function?

I am using a DB::CDBI class for accessing the database in our application. Our project is in object-oriented Perl.
package LT::LanguageImport;
use strict;
use warnings;
use base 'Misk5::CDBI';
__PACKAGE__->table( 'english_text_translation' );
__PACKAGE__->columns( Primary => qw/english language translation/ );
__PACKAGE__->columns( Essential => qw/english language translation/ );
__PACKAGE__->has_a( english => 'LT::EnglishLanguage' );
In one such scenario, I am supposed to check if a row in a table exists. I am using the built-in search API in a CDBI call.
sub find_translation {
my $translation_exists_r_not = $class->search(
english => $english,
language => $language,
translation => $translation
);
return;
}
$translation_exists_r_not is getting the expected values depending on the inputs given in the search. If the row exists, then the _data is updated with the row details.
$translation_exists_r_not = bless({
'_data' => [
{
'language' => 'polish',
'translation' => 'Admin',
'english' => 'admin'
}
],
'_place' => 0,
'_mapper' => [],
'_class' => 'LT::LanguageImport'
},
'Class::DBI::Iterator'
);
If the row desn't exist, then I get a return value like this.
$translation_exists_r_not = bless({
'_data' => [],
'_place' => 0,
'_mapper' => [],
'_class' => 'LT::LanguageImport'
},
'Class::DBI::Iterator'
);
I want to return the value of translation from this sub find_translation depending on the search result. I am not able to get a best condition for this.
I tried copying the _data into an array, but I'm not sure how to proceed further. As _data will be an empty arrayref and another condition it will have a hashref inside the arrayref.
my #Arr = $translation_exists_r_not->{'_data'};
CDBI's search method will return an iterator, because there may be multiple rows returned depending on your criteria.
If you know there can be only one row that matches your criteria, you want to use the retrieve method, i.e.:
if (my $translation_exists_r_not = $class->retrieve(
english => $english,
language => $language,
translation => $translation
)){
return [$translation_exists_r_not->translation,
'Misk5::TranslationAlreadyExists']
}
else {
return [ '', undef ]
}
And if multiple rows can be returned from your search, and you're only interested in the truthiness, then again, don't be rummaging around inside the CDBI::Iterator, but use its methods:
my $translation_exists_r_not = $class->search(
english => $english,
language => $language,
translation => $translation
); # returns an iterator
if ($translation_exists_r_not){
my $first = $translation_exists_r_not->first;
return [ $first->translation, 'Misk5::TranslationAlreadyExists' ]
}
Have a look at perldoc Class::DBI and perldoc Class::DBI::Iterator. CDBI has excellent documentation.
I think I got the solution. Thanks to whoever has tried to solve it.
my #req_array = %$translation_exists_r_not->{_data};
my $length_of_data = '9';
foreach my $elem (#req_array) {
$length_of_data = #{$elem};
}
Now check the length of the array.
if ($length_of_data == 0) {
$error = '';
$result = [undef, $error];
}
Now check if it is one.
if ($length_of_data == 1) {
my #result_array = #{%$translation_exists_r_not->{_data}};
my $translation = $result_array[0]{'translation'};
$error = 'Misk5::TranslationAlreadyExists';
$result = [$translation, $error];
}
return #$result;

Perl Catalyst DBIx Cursor Cache - how to clear?

apologises and thanks in advance for what, even as I type, seems likely silly question, but here goes anyway.
I have basic Catalyst application using DBIx::Class with an 'Author' and associated 'Book' table. In addition I also use DBIx::Class::Cursor::Cached to cache data as appropriate.
The issue is that, following an edit, I need to clear cached data BEFORE it has actually expired.
1.) Author->show_author_and_books which fetchs and caches resultset.
2.) the Book->edit_do which needs to clear the cached data from the Author->show_author_and_books request.
See basic/appropriate setup below.
-- MyApp.pm definition including backend 'Cache::FileCache' cache.
__PACKAGE__->config(
name => 'MyApp',
...
'Plugin::Cache' => { 'backend' => { class => 'Cache::FileCache',
cache_root => "./cache",
namespace => "dbix",
default_expires_in => '8 hours',
auto_remove_stale => 1
}
},
...
-- MyApp::Model::DB definition with 'Caching' traits set using 'DBIx::Class::Cursor::Cached'.
...
__PACKAGE__->config(
schema_class => 'MyApp::Schema',
traits => [ 'Caching' ],
connect_info => { dsn => '<dsn>',
user => '<user>',
password => '<password>',
cursor_class => 'DBIx::Class::Cursor::Cached'
}
);
...
-- MyApp::Controller::Author.pm definition with 'show_author_and_books' method - resultset is cached.
...
sub show_author_and_books :Chained('base') :PathPart('') :Args(0)
{
my ( $self, $c ) = #_;
my $author_id = $c->request->params->{author_id};
my $author_and_books_rs = $c->stash->{'DB::Author'}->search({ author_id => $author_id },
{ prefetch => 'book' },
cache_for => 600 } ); # Cache results for 10 minutes.
# More interesting stuff, but no point calling $author_and_books_rs->clear_cache here, it would make no sense:s
...
}
...
-- MyApp::Controller::Book.pm definition with 'edit_do' method which updates book entry and so invalidates the cached data in show_author_and_books.
...
sub edit_do :Chained('base') :PathPart('') :Args(0)
{
my ( $self, $c ) = #_;
# Assume stash contains a book for some author, and that we want to update the description.
my $book = $c->stash->{'book'}->update({ desc => $c->request->params->{desc} });
# How do I now clear the cached DB::Author data to ensure the new desc is displayed on next request to 'Author->show_author_and_books'?
# HOW DO I CLEAR CACHED DB::Author DATA?
...
}
Naturally I'm aware that $author_and_books_rs, as defined in Author->show_author_and_books, contains a method 'clear_cache', but obviously this is out of scope in Book->edit_do ( not to mention another problem there might be).
So, is the correct approach to make the DBIx request again , as per ...show_author_and_books and then call the 'clear_cache' again that or is there a more direct way where I can just say something like this $c->cache->('DB::Author')->clear_cache?
Thank you again.
PS. I'm sure when I look at this tomorrow, the full silliness of the question will hit me:s
Try
$c->model( 'DB::Author' )->clear_cache() ;
The solution I went for in the end was to NOT use 'DBIx::Class::Cursor::Cached', but instead directly use the Catalyst Cache plugin defining multiple
backend caches to handle the different namespaces I trying to manage in the real-world scenario.
I backed away from D::C::Cursor::Cached as all data was/is held in the same namespace plus there doesn't appear to be a method to expire data in advance of
time already set.
So for completeness, from the code above, the MyApp::Model::DB.pm definition would lose the 'traits' and 'cursor_class' key/values.
Then...
The MyApp.pm Plugin::Cache' would expand to contain multiple cache namespaces...
-- MyApp.pm definition including backend 'Cache::FileCache' cache.
...
'Plugin::Cache' => { 'backends' => { Authors => { class => 'Cache::FileCache',
cache_root => "./cache",
namespace => "Authors",
default_expires_in => '8 hours',
auto_remove_stale => 1
},
CDs => { class => 'Cache::FileCache',
cache_root => "./cache",
namespace => "CDs",
default_expires_in => '8 hours',
auto_remove_stale => 1
},
...
}
...
-- MyApp::Controller::Author.pm definition with 'show_author_and_books' method - resultset is cached.
...
sub show_author_and_books :Chained('base') :PathPart('') :Args(0)
{
my ( $self, $c ) = #_;
my $author_id = $c->request->params->{author_id};
my $author = $c->get_cache_backend('Authors')->get( $author_id );
if( !defined($author) )
{
$author = $c->stash->{'DB::Author'}->search({ author_id => $author_id },
{ prefetch => 'book', rows => 1 } )->single;
$c->get_cache_backend('Authors')->set( $author_id, $author, "10 minutes" );
}
# More interesting stuff, ...
...
}
...
-- MyApp::Controller::Book.pm definition with 'edit_do' method which updates book entry and so invalidates the cached data in show_author_and_books.
...
sub edit_do :Chained('base') :PathPart('') :Args(0)
{
my ( $self, $c ) = #_;
# Assume stash contains a book for some author, and that we want to update the description.
my $book = $c->stash->{'book'}->update({ desc => $c->request->params->{desc} });
# How do I now clear the cached DB::Author data to ensure the new desc is displayed on next request to 'Author->show_author_and_books'?
# HOW DO I CLEAR CACHED DB::Author DATA? THIS IS HOW, EITHER...
$c->get_cache_backend('Authors')->set( $c->stash->{'book'}->author_id, {}, "now" ); # Expire now.
# ... OR ... THE WHOLE Authors namespace...
$c->get_cache_backend('Authors')->clear;
...
}
NOTE : as you'll expect from the use of Author and CDs, this isn't the real world scenario I'm working, but should serve to show my intent.
As I'm relatively new to the wonder of DBIx and indeed Catalyst, I'd be interested to hear if there a better approach to this (I very much expect there is), but it will serve for the moment as I'm attempting to update a legacy application.
The plugin could probably be patched to make per result set caches easy to namespace and clear independently, and alternatively it would probably not be so hard to add a namespace to the attributes. If you want to work on that hit #dbix-class and I'd be willing to mentor you - jnap

How can I create a hash of hashes from an array of hashes in Perl?

I have an array of hashes, all with the same set of keys, e.g.:
my $aoa= [
{NAME=>'Dave', AGE=>12, SEX=>'M', ID=>123456, NATIONALITY=>'Swedish'},
{NAME=>'Susan', AGE=>36, SEX=>'F', ID=>543210, NATIONALITY=>'Swedish'},
{NAME=>'Bart', AGE=>120, SEX=>'M', ID=>987654, NATIONALITY=>'British'},
]
I would like to write a subroutine that will convert this into a hash of hashes using a given key hierarchy:
my $key_hierarchy_a = ['SEX', 'NATIONALITY'];
aoh_to_hoh ($aoa, $key_hierarchy_a) = #_;
...
}
will return
{M=>
{Swedish=>{{NAME=>'Dave', AGE=>12, ID=>123456}},
British=>{{NAME=>'Bart', AGE=>120, ID=>987654}}},
F=>
{Swedish=>{{NAME=>'Susan', AGE=>36, ID=>543210}}
}
Note this not only creates the correct key hierarchy but also remove the now redundant keys.
I'm getting stuck at the point where I need to create the new, most inner hash in its correct hierarchical location.
The problem is I don't know the "depth" (i.e. the number of keys). If I has a constant number, I could do something like:
%h{$inner_hash{$PRIMARY_KEY}}{$inner_hash{$SECONDARY_KEY}}{...} = filter_copy($inner_hash,[$PRIMARY_KEY,$SECONDARY_KEY])
so perhaps I can write a loop that will add one level at a time, remove that key from the hash, than add the remaining hash to the "current" location, but it's a bit cumbersome and also I'm not sure how to keep a 'location' in a hash of hashes...
use Data::Dumper;
my $aoa= [
{NAME=>'Dave', AGE=>12, SEX=>'M', ID=>123456, NATIONALITY=>'Swedish'},
{NAME=>'Susan', AGE=>36, SEX=>'F', ID=>543210, NATIONALITY=>'Swedish'},
{NAME=>'Bart', AGE=>120, SEX=>'M', ID=>987654, NATIONALITY=>'British'},
];
sub aoh_to_hoh {
my ($aoa, $key_hierarchy_a) = #_;
my $result = {};
my $last_key = $key_hierarchy_a->[-1];
foreach my $orig_element (#$aoa) {
my $cur = $result;
# song and dance to clone an element
my %element = %$orig_element;
foreach my $key (#$key_hierarchy_a) {
my $value = delete $element{$key};
if ($key eq $last_key) {
$cur->{$value} ||= [];
push #{$cur->{$value}}, \%element;
} else {
$cur->{$value} ||= {};
$cur = $cur->{$value};
}
}
}
return $result;
}
my $key_hierarchy_a = ['SEX', 'NATIONALITY'];
print Dumper(aoh_to_hoh($aoa, $key_hierarchy_a));
As per #FM's comment, you really want an extra array level in there.
The output:
$VAR1 = {
'F' => {
'Swedish' => [
{
'ID' => 543210,
'NAME' => 'Susan',
'AGE' => 36
}
]
},
'M' => {
'British' => [
{
'ID' => 987654,
'NAME' => 'Bart',
'AGE' => 120
}
],
'Swedish' => [
{
'ID' => 123456,
'NAME' => 'Dave',
'AGE' => 12
}
]
}
};
EDIT: Oh, BTW - if anyone knows how to elegantly clone contents of a reference, please teach. Thanks!
EDIT EDIT: #FM helped. All better now :D
As you've experienced, writing code to create hash structures of arbitrary depth is a bit tricky. And the code to access such structures is equally tricky. Which makes one wonder: Do you really want to do this?
A simpler approach might be to put the original information in a database. As long as the keys you care about are indexed, the DB engine will be able to retrieve rows of interest very quickly: Give me all persons where SEX = female and NATIONALITY = Swedish. Now that sounds promising!
You might also find this loosely related question of interest.