Cloning Objects in Perl

Author: fREW Schmidt

19 Sep

Recently I needed to do some deep cloning of some objects at work. I think I ended up looking at all of the major ways to do it, and I figure I might as well discuss them here.

What is deep cloning?

Nearly everyone should be able to answer this, but it doesn’t hurt to define it anyway. Deep cloning means you clone other things the current object is related to, recursively. So while a shallow clone of a hashref (in Perl) would be merely:

1	my $clone = { %{ $other_hash_ref } };

That doesn’t do if the things in the hash get mutated and are also references, because in that case you’ll be modifying parts of the other hash, possibly surprisingly.

Isn’t this solved?

Well yes. If it’s something as basic as a simple data structure you can just use Storable. The code for above would become:

1 2	use Storable 'dclone'; my $clone = dclone($other_hash_ref);

Storable has been core enough for long enough that if it’s not core you need to upgrade

What’s your problem?

Sadly just default Storable isn’t good enough. I needed to deeply clone the objects, but not clone any related schemata. That is, the objects had a DBIx::Class::Schema object attached to them and for various reasons I do not want to clone that at all. The correct way to deal with such an issue is to define the two Storable hooks as follows:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29

my @stack;
sub STORABLE_freeze {
my ($self, $cloning) = @_;

die q(you can't freeze this thing silly!) unless $cloning;

my %ret = %$self;

my %frame;
$frame{schema} = delete $ret{schema};
push @stack, \%frame;

return \%ret
}

sub STORABLE_thaw {
my ($self, $cloning, $ice) = @_;

die q(you can't thaw this thing silly!) unless $cloning;
my %frame = %{pop @stack};
my $new = $self->new({
%$self,
map {
$_ => $frame{$_}
} keys %frame,
});

%$self = %$new;
}

This is a little more generic than you probably need, and came from my prototype module, Clone::Hooker, but I gave up on that as well as Storable.

Why did you give up on Storable?

Two reasons; first, defining the hooks above might be a bad thing. Storable is something that someone other than me may use, and by defining the hooks above I am changing the relatively generic interface of Storable for my module. Second, there’s a better alternative that I ended up using.

WHAT DID YOU DO?!

I ended up settling on the handy MooseX::Clone. Obviously it is for Moose modules only, but all of my modules are Moose objects in this case. It’s very simple to use, here’s how it works for me:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35

package Dashboard;

use Moose;

with 'MooseX::Clone';

has gadgets => (
is => 'rw',
isa => 'ArrayRef',
traits => [qw(Clone)],
);

1;

package Gadget;

use Moose;

with 'MooseX::Clone';

has schema => (
is => 'ro',
);

1;

my $d = Dashboard->new(
gadgets => [
Gadget->new(
schema => $schema,
)
]
);

my $cloned_d = $d->clone;

This avoids the “global” nature of changing the interface of Storable, is fairly unobtrusive in my code, and works well.

0 Comments

Filed under: Uncategorized

Creating a pseudo attribute with DBIx::Class

Author: fREW Schmidt

3 Sep

I’m surprised I haven’t actually blogged this before. I had to do it recently for the first time in a long time and I figured I’d share the secret sauce.

At work we just added a complete permission system on top of our existing user system, but we didn’t want to make the UI as flexible as the underlying code. We ended up making a single role (which has all permissions) called “Full Control”. Without that role all you get is the stuff configured directly for your user; that is, your user gets a dashboard. So instead of making a grid of roles etc etc we just made a single checkbox on the user edit form. Of course I could have put in controller code to handle this special case, but I’m trying to get better at factoring code correctly. (As an aside: two years ago I would have also put all of this in the model; the frustrating thing is that Fat Model Skinny Controller only really works for relatively small apps. I’ll try to do a blog post on why I think that at another point later )

Anyway, first off, here’s the full_control accessor I made:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15

sub full_control {
my $self = shift;

if (exists $_[0]) {
my $full_control = $_[0];
if ($full_control) {
$self->set_roles({ name => FULL_CONTROL });
} else {
$self->user_roles->delete;
}
return $full_control
} else {
$self->roles->search({ name => FULL_CONTROL })->count
}
}

Not a whole lot going on. If an argument is passed we set the user’s roles based on the truthiness of the argument. Because the system is currently just the one role we delete all roles for clearing it. Later on if we make the system more full featured we’ll have to change this up a bit of course. If no argument is passed we just return the count of full control roles, as that approximates truthiness just fine.

Next up are the “insert” and update wrappers. I quote insert because I actually override new:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23

sub update {
my ($self, $args, @rest) = @_;

my $full_control = delete $args->{full_control};

my $ret = $self->next::method($args, @rest);

$ret->full_control($full_control);

return $ret
}

sub new {
my ($self, $args, @rest) = @_;

my $full_control = delete $args->{full_control};

$args->{user_roles} = [ { role => { name => 'Full Control' } } ] if $full_control;

my $ret = $self->next::method($args, @rest);

return $ret
}

The code for update should be abundantly clear. We just update the object, calling our accessor afterwards. The new code is a little bit more messy. Basically, instead of trying to use the accessor on new (which is wrong as new doesn’t actually imply an insert) we just leverage the excellent MultiCreate which DBIx::Class provides for us.

And that’s it! I hope this helps you get your job done that much faster/better

0 Comments

Filed under: Uncategorized

Smalltalk Best Practice Patterns – Constructor Parameter Method

Author: fREW Schmidt

3 Sep

How do you set instance variables from a constructor method?

The fundamental issue here is that often validation is bypassed at construction time, for whatever reason. So one’s accessor may look something like this:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19

sub x {
my $self = shift;

if ($self->constructing) {
if (exists $_[0]) {
$self->{x} = $_[0];
} else {
return $self->{x}
}
} else {
if (exists $_[0]) {
die 'too high!' if $_[0] > 100;
die 'too low!' if $_[0] < 0;
$self->{x} = $_[0];
} else {
return $self->{x}
}
}
}

Clearly this method is just doing to much. To solve this we make special set methods that are entirely to be used during construction. So in Perl this might look like the following:

1
2
3
4

sub _set_x {
my ($self, $x) = @_;
$self->{x} = $x;
}

Interestingly, with Moose we happily side-step this issue, as the default constructor doesn’t go through the accessors and already sets the raw values.

Ok, so I think I may start trying to apply this stuff to JavaScript instead of Perl. I almost feel like the fact that I have Moose in Perl is cheating. I know that there is Joose in JavaScript, but I’ve yet to use that in production, and I find that I have a harder time making well factored code in JavaScript than Perl. Part of that is that the underlying libraries I use in JS (ExtJS 3) are not really well factored either, but I still struggle with overall structure.

1 Comment

Filed under: Uncategorized

Stop accidentally committing all with git

Author: fREW Schmidt

28 Aug

One of the things that annoys me a lot when using git is if I go through a lot of work to stage some changes, probably using `git add -p` to stage parts of files, and then from muscle memory I type `git ci -am ‘lolol I dummy’`. If you didn’t know the -a says commit everything, so then of my painstaking staging is gone.

Well, on Thursday I finally fixed this problem. I wrote the following, very basic, git wrapper. All it does is:

Find all aliases for commit
Check if the current command is a commit or commit alias
Check if the current arguments have -a or –all
Check if there are staged modifications
And if all of those conditions are true, it prompts the user to ensure that they actually want to commit all.

I’m fairly happy with the alias detection; the only thing it should also do is introspect the arguments in the values of the alias as well as the current command. I don’t have any aliases like that, but if I wanted to make this a canned solution that would be a must.

The arguments detection is actually very dumb. It wouldn’t work if you did `git ci -m ‘Foo’ -a`. I’m ok with that because this is to battle my own muscle memory and I would never type that. But it is definitely a spot for improvement.

The staged checking I am very happy with. It only checks for staged modifications. So if you add a new file or delete a file and then do `git ci -am “station”` it will happily go on it’s way, which I like.

Anyway, here’s the script. To install it just put it somewhere in your path as wrap-git (I use ~/bin) and alias git=wrap-git

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35

#!/usr/bin/env perl

use strict;
use warnings;

my %aliases = map { split(/\n/, $_, 2) }
split /\0/,
`git config -z --get-regexp alias\\.`;

my %commit_aliases = (( commit => 1 ),
map { s/alias\.//; $_ => 1 }
grep $aliases{$_} =~ /^commit\b/,
keys %aliases);

my ($command, @args) = @ARGV;

if ($commit_aliases{$command} && $args[0] =~ /^-a|^--all/) {
my @staged = grep /^M/, split /\0/, `git status -z`;
if (@staged) {
print "There are staged changes, are you sure you want to commit all? (y/N) ";
chomp(my $answer = <STDIN>);
if ($answer =~ /^y/i) {
run_command()
}
} else {
run_command()
}
} else {
run_command()
}

sub run_command {
system 'git', $command, @args;
exit $? >> 8;
}

One thing I think would be really cool would be to make a WrapGit.pm and wrap-git would just be coderefs passed to WrapGit.pm. I’d love to have full introspection of all git commands and arguments. It would let me do things like keep statistics about how you use git, maybe make a powerful achievement system, make more commands prompt the way this one does. Anyway, I’ll probably do that one of these days when I finish all the other stuff on my list

1 Comment

Filed under: Uncategorized

Refactoring Dispatch Tables into Objects

Author: fREW Schmidt

24 Aug

One of the cool ways of doing things in Perl is to use a dispatch table. The most obvious dispatch table is a hash of subroutines:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16

my $x;

my $table = {
GET => sub { return $x },
PUT => sub { $x = $_[0] },
};

sub dispatch {
my ($method, $data) = @_;

if (my $fn = $table->{$method}) {
$fn->($data)
} else {
die 'METHOD NOT ALLOWED!'
}
}

This is a pretty cool thing to be able to do easily. But what’s even cooler is that we can refactor the dispatch table into a package, which allows us to make objects that can override bits of the dispatch table:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25

package Table {
sub new { bless {}, $_[0] }
sub GET { return $_[0]->{x} }
sub PUT { $_[0]->{x} = $_[1] }
}

package SubTable {
use parent 'Table';
sub DELETE { delete $_[0]->{x} }
}

my $table = SubTable->new;
sub dispatch {
my ($method, $data) = @_;

if (my $fn = $table->can($method)) {
$table->$method($data)

# the following would also work and would be
# marginally faster
# $table->$fn($data)
} else {
die 'METHOD NOT ALLOWED!'
}
}

Note that one thing you might consider is prefixing the methods with “public_” or something like that; just in case your dispatcher object as private methods you don’t want web browsers executing. Generally though I’d just not put such methods in my dispatcher, but I haven’t yet made anything super complex using this pattern. I am using the pattern for a pluggable dashboard system at work, but the methods there are all called GET_foo or POST_bar, so users can’t run methods I didn’t specifically make for HTTP.

4 Comments

Filed under: Uncategorized

New Stuff in Catalyst::ActionRole::PseudoCache 1.000001

Author: fREW Schmidt

22 Aug

I’m excited to announce a new version of Catalyst::ActionRole::PseudoCache.

New in the current release of Catalyst::ActionRole::PseudoCache is that it can now use Catalyst::Plugin::Cache as the underlying cache mechanism. The main reason was that the existing architecture didn’t work for multiple servers, which is how our system works. Plus this is just better overall.

In the long term I will be removing the old “Pseudo” cache. It might be a good idea to make a separate package with a better name at some point, but that will be for the next release. Enjoy!

0 Comments

Filed under: Uncategorized

Weekly Status Report 3

Author: fREW Schmidt

22 Aug

I don’t feel great about this past week, but I was really busy with wedding planning stuff. I barely made either of my two main goals (2 blog posts and 2 patches/releases a week.)

Last week I:

Released a new version of Log::Contextual
Released a new version of DBIx::Class::Helpers

I have high hopes for the coming week, that I can get more important releases and more interesting blog posts written. Stay tuned!

0 Comments

Filed under: Uncategorized

Weekly Status Report 2

Author: fREW Schmidt

15 Aug

This week I:

Released a new version of Class::C3::Componentised
Released a new version of DBIx::Class::Candy

0 Comments

Filed under: Uncategorized

Powerful benchmarking with Perl and ab

Author: fREW Schmidt

11 Aug

One of my projects at work was to make an SMS (and voice actually) gateway. The gist is that instead of our customers each having an account with whatever text message company, they go through us. The benefit is that with a larger pool of users for the text messages users can have a lot more flexibility with how they use their messages. Most gateways sell you messages per month, and we sell yearly messages.

One of the major uses of our software is for duress; that is, sending text messages to all the students at a college in an emergency (note: sending SMS in an emergency is a really bad idea, but people want to do it …) Because of this we really want to put a premium on how many we can send at a time. Our old gateway (non-persistent Perl, weird database, bad API) was excruciatingly slow.

To test the speed of our server when sending a large number of messages from a single server I wrote the following script to test a number of different situations.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37

#!/usr/bin/env perl

use strict;
use warnings;

use JSON;

use Getopt::Long::Descriptive;

my ($opt, $usage) = describe_options(
'benchmark.pl %o',
[ 'concurrent|c=i', 'number of concurrent connections', {default => 5 } ],
[ 'destinations|d=i', "number of destinations to submit", { default => 100 } ],
[ 'total-iterations|n=i', "number of iterations to run", { default => 100 } ],
[],
[ 'help|h|?', 'print usage message and exit' ],
);

print($usage->text), exit if $opt->help;

open my $fh, '>', 'testtest';
print {$fh} to_json({
message => 'HELP! BUILDING IS ON FIRE!',
destinations => [map +{
phone_number => 1000000000 + $_,
child_id => $_,
}, 1..($opt->destinations)]
});

system(
'ab',
qw(-T application/json),
'-n' => $opt->total_iterations,
qw(-p testtest),
'-c' => $opt->concurrent,
'http://10.6.1.56:3000/api/1/test/sms'
);

So we have a handful of nice commandline options, we generate a file of JSON, and then we have ab run the actual speed test.

One of the really neat things you can do is have perl run more than one ab instance at a time, this allowing you to test multiple urls, which ab doesn’t support natively.

Anyway, good luck speed testing the hotspots in your app!

1 Comment

Filed under: Uncategorized