DBIx::Class Wrapping/overloading a column accessor - perl

Using DBIx::Class I am trying to manipulate the data of a column whenever it is being updated or retrieved. For instance, before it goes into the database I would like to encrypt it, and whenever it is being accessed I would like to decrypt it. I am following this example in the DBIx::Class::Manual::Cookbook, however I can't seem to get it to work. I have placed the following in my User schema. For testing I am just using the name column, I know it doesn't make sense:
__PACKAGE__->add_columns("name" => { accessor => '_name' });
sub name {
my $self = shift;
# If there is an update to the column, we'll let the original accessor
# deal with it.
if(#_) {
return $self->_name('test 1');
}
# Fetch the column value.
my $name = $self->_name;
$name = 'test 2';
return $name;
}
I can't see what I'm doing any different than what the cookbook says. Can't anyone help me understand what I'm doing wrong? Thanks!

DBIx::Class has a component for that called FilterColumn.
There are various modules on CPAN using that component like DBIx::Class::EncodedColumn and PassphraseColumn.
If you tell us what you use case is we might give you more/better suggestions.

Related

TreeModelFilter in GTK/Perl - Question about set_visible_func

I am trying to filter a liststore using the GTK2::TreeModelFilter. I can't seem to find an example online that uses perl and I am getting syntax errors. Can someone help me with the syntax below? The $unfiltered_store is a liststore.
$filtered_store = Gtk2::TreeModeFilter->new($unfiltered_store);
$filtered_store->set_visible_func(get_end_products, $unfiltered_store);
$combobox = Gtk2::ComboBoxEntry->new($filtered_store,1);
Then somewhere below:
sub get_end_products {
my ($a, $b) = #_;
warn(Dumper(\$a));
warn(Dumper(\$b));
return true; # Return all rows for now
}
Ultimately what I want to do is look at column 14 of the listore ($unfiltered_store) and if it is a certain value, then it filtered into the $filtered_store.
Can someone help me with the syntax on this? I checked a bunch of sites, but they're in other languages and using different syntax (like 'new_filter' -- doesn't exist with Perl GTK).
This is the most elegant solution to a fix I need to make and I would prefer to learn how to use this rather than using a brute force method of pulling and saving the filtered data.
The set_visible_func method of the filtered store should get a sub reference as the first argument, but you are not passing a sub reference here:
$filtered_store->set_visible_func(get_end_products, $unfiltered_store);
This will instead call the sub routine get_end_products and then pass on its return value (which is not a sub reference). To fix it add the reference operator \& in front of the sub name:
$filtered_store->set_visible_func(\&get_end_products, $unfiltered_store);
Regarding your other question in the comments:
According to the documentation the user data parameter is passed as the third parameter to get_end_products, so you should define it like this:
sub get_end_products {
my ($model, $iter, $user_data) = #_;
# Do something with $user_data
return TRUE;
}
If for some reason $unfiltered_store is not passed on to get_end_products, you can try pass it using an anonymous sub instead, like this:
$filtered_store->set_visible_func(
sub { get_end_products( $unfiltered_store) });

How can I alter a DBIx::Class object value without updating the actual DB

I am checking for mismatch usernames in one of my applications.
If it finds a mismatch username, I wrap the value in <mark> tags.
I want to update my DBIx::Class object's username value before passing it back to my JS.
I currently have the below, which is almost what I want but not quite.
my $mismatch_username = check_for_mismatch_username($self, $id, 'AD');
if(defined $mismatch_username)
{
my $flagged_username = "<mark>".$info->accountname."</mark> <font color=\"red\">(Mismatch: $mismatch_username)</font>";
$info->update({accountname => $flagged_username});
}
$info = {$info->get_columns};
$self->render(json => {info => $info});
It is very important I don't update the DB value. I only want to update the variable's value. I am currently still looking through the DBIx::Class documentation.
Any direction is appreciated.
Don't modify the object if you don't want it to be modified.
(You could, of course, update the field without saving it using $info->accountname(…). But that would still leave the object in a modified state, where other code could potentially save it. It'd also potentially fail if the HTML markup was rejected by a validator on the field.)
If all you actually need is to change the username in the JSON, generate the data that'll go into the JSON first, then update the appropriate field in the data before rendering it:
my $data = { $info->get_columns };
if (defined $mismatch_username) {
$data->{accountname} = "<mark>…";
}
$self->render(json => { info => $data });

Bridge handler can't access stash data

I have the following code in our webapp written using Mojolicious, and it doesn't work as expected: the bridge handler doesn't get the correct stash data derived from routes (gets undef), so the rest of code fails, however, debug output of $self->stash('city') in any of route handlers is as expected.
...
# Router.
my $r = $self->routes->bridge->to('Main#common');
$r->route('/')->to('Main#index')->name('start');
$r->route('/:region/:city/category/:id')->to('Main#list_category')->name('list_category');
$r->route('/:region/:city/part/:id/:name')->to('Main#show_part')->name('show_part');
...
# Controller.
sub common
{
my $self=shift;
my $db=$self->db;
my $city=$self->stash('city');
my $region=$self->db->selectrow_hashref('select * from region where LOWER(translit)=? ORDER BY region_id LIMIT 1',undef,$city);
say "City=$city.";
if(!$region)
{
$region={};
}
$self->stash(region=>$region);
return 1;
}
...
I think it's correct behavior.
Look at this code.
Placeholder is added when the appropriate route is taken to the processing, i.e., step by step.
Really, look at you routes.
my $r = $self->routes->bridge->to('Main#common');
$r->route('/')->to('Main#index')->name('start');
$r->route('/:region/:city/category/:id')->to('Main#list_category')->name('list_category');
$r->route('/:region/:city/part/:id/:name')->to('Main#show_part')->name('show_part');
I can't understand what behavior you expect when go to route /.
Sub common will be invoked in this case. There are no value for placeholder city!
So, correct solution for your routes must look like this:
my $r = $self->routes;
$r->route('/')->to('Main#index')->name('start');
my $r_city = $r->bridge('/:region/:city/')->to('Main#common');
$r_city->route('/category/:id')->to('Main#list_category')->name('list_category');
$r_city->route('/part/:id/:name')->to('Main#show_part')->name('show_part');
By the way,
starting from Mojolicious version 6.0 bridge was deprecated to favor under. So, you need to replace bridge on under.
But, if you very-very want to have value of placeholder city in common function, you may look at this two line.
You need to write this BAD code in common sub:
sub common {
my $self = shift;
my $stack = $self->match->stack;
warn $self->dumper($stack);
...
}
Print $stack and you understand how to get value of placeholder city.

Perl OOP attribute manipulation best practice

Assume the following code:
package Thing;
sub new {
my $this=shift;
bless {#_},$this;
}
sub name {
my $this=shift;
if (#_) {
$this->{_name}=shift;
}
return $this->{_name};
}
Now assume we've instantiated an object thusly:
my $o=Thing->new();
$o->name('Harold');
Good enough. We could also instantiate the same thing more quickly with either of the following:
my $o=Thing->new(_name=>'Harold'); # poor form
my $o=Thing->new()->name('Harold');
To be sure, I allowed attributes to be passed in the constructor to allow "friendly" classes to create objects more completely. It could also allow for a clone-type operator with the following code:
my $o=Thing->new(%$otherthing); # will clone attrs if not deeper than 1 level
This is all well and good. I understand the need for hiding attributes behind methods to allow for validation, etc.
$o->name; # returns 'Harold'
$o->name('Fred'); # sets name to 'Fred' and returns 'Fred'
But what this doesn't allow is easy manipulation of the attribute based on itself, such as:
$o->{_name}=~s/old/ry/; # name is now 'Harry', but this "exposes" the attribute
One alternative is to do the following:
# Cumbersome, not syntactically sweet
my $n=$o->name;
$n=~s/old/ry/;
$o->name($n);
Another potential is the following method:
sub Name :lvalue { # note the capital 'N', not the same as name
my $this=shift;
return $this->{_name};
}
Now I can do the following:
$o->Name=~s/old/ry/;
So my question is this... is the above "kosher"? Or is it bad form to expose the attribute that way? I mean, doing that takes away any validation that might be found in the 'name' method. For example, if the 'name' method enforced a capital first letter and lowercase letters thereafter, the 'Name' (capital 'N') bypasses that and forces the user of the class to police herself in the use of it.
So, if the 'Name' lvalue method isn't exactly "kosher" are there any established ways to do such things?
I have considered (but get dizzy considering) things like tied scalars as attributes. To be sure, it may be the way to go.
Also, are there perhaps overloads that may help?
Or should I create replacement methods in the vein of (if it would even work):
sub replace_name {
my $this=shift;
my $repl=shift;
my $new=shift;
$this->{_name}=~s/$repl/$new/;
}
...
$o->replace_name(qr/old/,'ry');
Thanks in advance... and note, I am not very experienced in Perl's brand of OOP, even though I am fairly well-versed in OOP itself.
Additional info:
I guess I could get really creative with my interface... here's an idea I tinkered with, but I guess it shows that there really are no bounds:
sub name {
my $this=shift;
if (#_) {
my $first=shift;
if (ref($first) eq 'Regexp') {
my $second=shift;
$this->{_name}=~s/$first/$second/;
}
else {
$this->{_name}=$first;
}
}
return $this->{_name};
}
Now, I can either set the name attribute with
$o->name('Fred');
or I can manipulate it with
$o->name(qr/old/,'ry'); # name is now Harry
This still doesn't allow stuff like $o->name.=' Jr.'; but that's not too tough to add. Heck, I could allow calllback functions to be passed in, couldn't I?
Your first code example is abolutely fine. This is a standard method to write accessors. Of course this can get ugly when doing a substitution, the best solution might be:
$o->name($o->name =~ s/old/ry/r);
The /r flag returns the result of the substitution. Equivalently:
$o->name(do { (my $t = $o->name) =~ s/old/ry/; $t });
Well yes, this 2nd solution is admittedly ugly. But I am assuming that accessing the fields is a more common operation than setting them.
Depending on your personal style preferences, you could have two different methods for getting and setting, e.g. name and set_name. (I do not think get_ prefixes are a good idea – 4 unneccessary characters).
If substituting parts of the name is a central aspect of your class, then encapsulating this in a special substitute_name method sounds like a good idea. Otherwise this is just unneccessary ballast, and a bad tradeoff for avoiding occasional syntactic pain.
I do not advise you to use lvalue methods, as these are experimental.
I would rather not see (and debug) some “clever” code that returns tied scalars. This would work, but feels a bit too fragile for me to be comfortable with such solutions.
Operator overloading does not help with writing accessors. Especially assignment cannot be overloaded in Perl.
Writing accessors is boring, especially when they do no validation. There are modules that can handle autogeneration for us, e.g. Class::Accessor. This adds generic accessors get and set to your class, plus specific accessors as requested. E.g.
package Thing;
use Class::Accessor 'antlers'; # use the Moose-ish syntax
has name => (is => 'rw'); # declare a read-write attribute
# new is autogenerated. Achtung: this takes a hashref
Then:
Thing->new({ name => 'Harold'});
# or
Thing->new->name('Harold');
# or any of the other permutations.
If you want a modern object system for Perl, there is a row of compatible implementations. The most feature-rich of these is Moose, and allows you to add validation, type constraints, default values, etc. to your attributes. E.g.
package Thing;
use Moose; # this is now a Moose class
has first_name => (
is => 'rw',
isa => 'Str',
required => 1, # must be given in constructor
trigger => \&_update_name, # run this sub after attribute is set
);
has last_name => (
is => 'rw',
isa => 'Str',
required => 1, # must be given in constructor
trigger => \&_update_name,
);
has name => (
is => 'ro', # readonly
writer => '_set_name', # but private setter
);
sub _update_name {
my $self = shift;
$self->_set_name(join ' ', $self->first_name, $self->last_name);
}
# accessors are normal Moose methods, which we can modify
before first_name => sub {
my $self = shift;
if (#_ and $_[0] !~ /^\pU/) {
Carp::croak "First name must begin with uppercase letter";
}
};
The purpose of class interface is to prevent users from directly manipulating your data. What you want to do is cool, but not a good idea.
In fact, I design my classes, so even the class itself doesn't know it's own structure:
package Thingy;
sub new {
my $class = shift;
my $name = shift;
my $self = {};
bless, $self, $class;
$self->name($name);
return $self;
}
sub name {
my $self = shift;
my $name = shift;
my $attribute = "GLUNKENSPEC";
if ( defined $name ) {
$self->{$attribute} = $name;
}
return $self->{$attribute};
}
You can see by my new constructor that I could pass it a name for my Thingy. However, my constructor doesn't know how I store my name. Instead, it merely uses my name method to set the name. As you can see by my name method, it stores the name in an unusual way, but my constructor doesn't need to know or care.
If you want to manipulate the name, you have to work at it (as you showed):
my $name = $thingy->name;
$name =~ s/old/ry/;
$thingy->name( $name );
In fact, a lot of Perl developers use inside out classes just to prevent this direct object manipulation.
What if you want to be able to directly manipulate a class by passing in a regular expression? You have to write a method to do this:
sub mod_name {
my $self = shift;
my $pattern = shift;
my $replacement = shift;
if ( not defined $replacement ) {
croak qq(Some basic error checking: Need pattern and replacement string);
}
my $name = $self->name; # Using my name method for my class
if ( not defined $name ) {
croak qq(Cannot modify name: Name is not yet set.);
}
$name = s/$pattern/$replacement/;
return $self->name($name);
}
Now, the developer can do this:
my $thingy->new( "Harold" );
$thingy->mod_name( "old", "new" );
say $thingy->name; # Says "Harry"
Whatever time or effort you save by allowing for direct object manipulation is offset by the magnitude of extra effort it will take to maintain your program. Most methods don't take more than a few minutes to create. If I suddenly got an hankering to manipulate my object in a new and surprising way, it's easy enough to create a new method to do this.
1. No. I don't actually use random nonsense words to protect my class. This is purely for demo purposes to show that even my constructor doesn't have to know how methods actually store their data.
I understand the need for hiding attributes behind methods to allow for validation, etc.
Validation is not the only reason, although it is the only one you refer to. I mention this because another is that encapsulation like this leaves the implementation open. For example, if you have a class which needs to have a string "name" which can be get and set, you could just expose a member, name. However, if you instead use get()/set() subroutines, how "name" is stored and represented internally doesn't matter.
That can be very significant if you write bunches of code with uses the class and then suddenly realize that although the user may be accessing "name" as a string, it would be much better stored some other way (for whatever reason). If the user was accessing the string directly, as a member field, you now either have to compensate for this by including code that will change name when the real whatever is changed and...but wait, how can you then compensate for the client code that changed name...
You can't. You're stuck. You now have to go back and change all the code that uses the class -- if you can. I'm sure anyone who has done enough OOP has run into this situation in one form or another.
No doubt you've read all this before, but I'm bringing it up again because there are a few points (perhaps I've misunderstood you) where you seem to outline strategies for changing "name" based on your knowledge of the implementation, and not what was intended to be the API. That is very tempting in perl because of course there is no access control -- everything is essential public -- but it is still a very very bad practice for the reason just described.
That doesn't mean, of course, that you can't simply commit to exposing "name" as a string. That's a decision and it won't be the same in all cases. However, in this particular case, if what you are particularly concerned with is a simple way to transform "name", IMO you might as well stick with a get/set method. This:
# Cumbersome, not syntactically sweet
Maybe true (although someone else might say it is simple and straightforward), but your primary concern should not be syntactic sweetness, and neither should speed of execution. They can be concerns, but your primary concern has to be design, because no matter how sweet and fast your stuff is, if it is badly designed, it will all come down around you in time.
Remember, "Premature optimization is the root of all evil" (Knuth).
So my question is this... is the above "kosher"? Or is it bad form to expose the attribute that way?
It boils down to: Will this continue to work if the internals change? If the answer is yes, you can do many other things including but not limited to validation.)
The answer is yes. This can be done by having the method return a magical value.
{
package Lvalue;
sub TIESCALAR { my $class = shift; bless({ #_ }, $class) }
sub FETCH { my $self = shift; my $m = $self->{getter}; $self->{obj}->$m(#_) }
sub STORE { my $self = shift; my $m = $self->{setter}; $self->{obj}->$m(#_) }
}
sub new { my $class = shift; bless({}, $class) }
sub get_name {
my ($self) = #_;
return $self->{_name};
}
sub set_name {
my ($self, $val) = #_;
die "Invalid name" if !length($val);
$self->{_name} = $val;
}
sub name :lvalue {
my ($self) = #_;
tie my $rv, 'Lvalue', obj=>$self, getter=>'get_name', setter=>'set_name';
return $rv;
}
my $o = __PACKAGE__->new();
$o->name = 'abc';
print $o->name, "\n"; # abc
$o->name = ''; # Invalid name

Empty a dynamically created array in a Perl Module

Hi Guys need some help regarding modules and emptying dynamically created array in another module.
I have 1 perl file, and 2 perl modules ( i have created )
//file.pl
use ABC;
use XYZ;
for(qw/US UK China India France/)
{
ABC::fetchData // This will create array varialbes
XYZ::calculateYield
// This will use arrays dynamically created from fetchData
// At this point, when i return I want a new copy of the array used in XYZ.pm's calculateYield function
}
This is a an example of ABC.pm
//ABC.pm
package ABC;
our #mainArray;
sub fetchData
{
// connect to database and fill up the #mainArray;
#mainArray = qw/a b c d e f/;
}
1;
This is an example of XYZ.pm
//XYZ.pm
package XYZ;
sub calculateYield
{
foreach my $eachelement ( #ABC::mainArray)
{
push #{$eachelement), "some_data_that_changes_every_time_from India, UK, US, France or China";
}
}
Now, the problem lies here, I want to empty out the array "#{$eachelement}" after every call of for(1..5) , because the $eachelement stays the same in every count. Only the value of the data that is pushed into push #{$eachelement) in the XYZ module changes depending on the value ( US, UK, China, India, France).
Question for the group is, is there a way to empty out an array in a module whose name is dynamically created. As for example i want to clear out #{$eachelement} in the XYZ.pm after everytime the for loop is done.
Hope I have put it in a way that can be understood. If anyof you have a better solution or something else I can use,I am willing to do that. Ping me back if the question or any part of the code is not clear.
PS : I am not looking for a small error or typo, this is just a sample code. I just want to know how things can be done.
Thanks for the much anticipated help in advance.
I looked around and found a solution to this particular problem. I defined a global function
sub clear
{
for my $ref (values %MSQL::)
{
#{$ref} = ();
}
}
Thanks Guys for the support.
#Patrick , this was not a TYPO error. Like I said I was looking for the logic.