Perl's Moose is different from other object systems, so it's not always clear how to translate an example known from other languages into Moose lingo. Consider the following Java example of Rectangle and Square, where a Square instance (a square being a special rectangle) delegates calls to area() to an instance of Rectangle to which it hold a private reference.
package geometry;
class Rectangle {
private int x;
private int y;
public Rectangle(int x, int y) {
this.x = x;
this.y = y;
}
public int area() {
return x * y;
}
}
class Square {
private Rectangle rectangle;
public Square(int a) {
this.rectangle = new Rectangle(a, a);
}
public int area() {
return this.rectangle.area();
}
}
public class Main {
public static void main( String[] args ) {
int x, y;
if ( args.length > 1 ) {
x = Integer.parseInt( args[0] );
y = Integer.parseInt( args[1] );
}
else {
x = 3;
y = 7;
}
Rectangle r = new Rectangle( x, y );
System.out.println( r.area() );
Square sq1 = new Square( x );
System.out.println( sq1.area() );
Square sq2 = new Square( y );
System.out.println( sq2.area() );
}
}
I've cobbled together the following Perl/Moose/Mouse version, which I'm not sure is the right way to do things, so I'm submitting it to the judgment of the guild of experts assembled in these halls:
package Rectangle;
use Mouse;
has [ qw( x y ) ], is => 'ro', isa => 'Int';
sub area {
my( $self ) = #_;
return $self->x * $self->y;
}
package Square;
use Mouse;
has x => is => 'ro', isa => 'Int';
has rectangle => is => 'ro', isa => 'Rectangle';
# The tricky part: modify the constructor.
around BUILDARGS => sub {
my $orig = shift;
my $class = shift;
my %args = #_ == 1 ? %{ $_[0] } : #_;
$args{rectangle} = Rectangle->new( x => $args{x}, y => $args{x} );
return $class->$orig( \%args );
};
sub area { $_[0]->rectangle->area } # delegating
package main;
use strict;
my $x = shift || 3;
my $y = shift || 7;
my $r = Rectangle->new( x => $x, y => $y);
my $sq1 = Square->new( x => $x );
my $sq2 = Square->new( x => $y );
print $_->area, "\n" for $r, $sq1, $sq2;
This works, but as I haven't seen much Moose in action, I'm just not sure this is the way to go, or if there is an even easier way. Thanks for any feedback, or pointers for more Moose user-level discussion.
While I am not sure this is best practice, probably best translation I can think of would be something like this:
package Rectangle;
use Mouse;
has [ qw( x y ) ], is => 'ro', isa => 'Int';
sub area {
my( $self ) = #_;
return $self->x * $self->y;
}
package Square;
use Mouse;
has x => is => 'ro', isa => 'Int';
has rectangle =>
is => 'ro',
isa => 'Rectangle',
lazy_build => 1,
handles => [ 'area' ];
sub _build_rectangle {
my $self = shift;
Rectangle->new(x => $self->x, y => $self->x);
}
The handles in rectangle attribute automatically builds delegation to area for you.
This is how I'd do it with Moose. It's pretty much identical to the Mouse version:
use 5.012;
use Test::Most;
{
package Rectangle;
use Moose;
has [qw(x y)] => ( is => 'ro', isa => 'Int' );
sub area {
my $self = shift;
return $self->x * $self->y;
}
}
{
package Square;
use Moose;
has [qw(x y)] => ( is => 'ro', isa => 'Int' );
has rectangle =>
( isa => 'Rectangle', lazy_build => 1, handles => ['area'] );
sub _build_rectangle {
my $self = shift;
Rectangle->new( x => $self->x, y => $self->y );
}
}
my #dimensions
= ( [qw(Rectangle 3 7 21 )], [qw(Square 3 3 9 )], [qw(Square 3 7 21 )] );
for my $dimension (#dimensions) {
my ( $shape, $x, $y, $area ) = #{$dimension};
my $rect = new_ok $shape, [ x => $x, y => $y ];
is $area, $rect->area, "area of $shape ($x, $y) => $area";
}
done_testing;
Related
validate(
#_,
{
foo => {
callbacks => {
'smaller than a breadbox' => sub { shift() < $breadbox },
'green or blue' => sub {
return 1 if $_[0] eq 'green' || $_[0] eq 'blue';
&$failed(‘**fieldname** value is Invalid’);
}
bar => {
callbacks => {
'yellow or red' => sub {
return 1 if $_[0] eq 'yellow ' || $_[0] eq 'red';
&$failed(‘**fieldname** value is Invalid’);
}
}
}
}
);
Params::Validate - In the above code if my validation fails, I am calling the subroutine failed in which I am displaying the error message. I want to get field name from callbacks in params validate for which the validation has failed instead of directly passing the field name in the failed subroutine. Here foo and bar are fieldnames. How can I get the field name?
You could try something like this:
use strict;
use warnings;
use Params::Validate;
my %template =
(
bar => {
'color correct' => sub {
my ($fieldname, $value) = #_[0..1];
return 1 if $value eq 'green' || $value eq 'blue';
failed("'$fieldname': value '$value' is invalid");
}
},
foo => {
'smaller than a breadbox' => sub {
my ($fieldname, $value) = #_[0..1];
return 1 if $value < 20;
failed("'$fieldname' value '$value' is invalid");
}
}
);
func( bar => 'green', foo => 14 );
func( bar => 'yellow', foo => 17 );
sub func {
my %validate = map { $_ => { callbacks => get_callbacks( $_, $template{$_} ) } }
keys %template;
validate( #_, \%validate );
}
sub get_callbacks {
my ( $fname, $callbacks ) = #_;
my %cb;
for my $name (keys %$callbacks ) {
$cb{$name} = sub {
my $fieldname = $fname;
$callbacks->{$name}->( $fieldname, #_ )
};
}
return \%cb;
}
sub failed {
die $_[0];
}
Note: this uses closures to define a persistent fieldname variable. See perlsub for more information.
What is the best way to walk a nested hash structure to get the value when there can be an unknown number of nested levels?
For example the hash could be any of the following or any level of nesting.
my $hash = { 'known' => { 'a' => { 'b' => 'value' } } };
my $hash = { 'known' => { 'a' => { 'b' => { 'c' => 'value' } } } };
my $hash = { 'known' => { 'a' => { 'b' => { 'c' => { 'd' => 'value' } } } } };
The keys a,b,c below could be any value.
I was thinking I could do it with a recursive function that extracts the key and value and the current level, checks to see if the value is a reference to
a hash and if so calls itself, otherwise I have the value?
An easy-to-read approach:
#!/usr/bin/env perl
use strict;
use warnings;
my $hash = { 'known' => { 'a' => { 'b' => 'value' } } };
print get_deep_values($hash);
sub get_deep_values {
my $hash = shift;
if (ref($hash) eq 'HASH') {
get_deep_values( (values %$hash)[0] )
}
else {
return $hash;
}
}
Output:
value
Yes, recursion works,
use v5.16;
use warnings;
my $hash = { 'known' => { 'a' => { 'b' => 'value' } } };
print sub { map { ref() ? __SUB__->(values %$_) : $_ } #_ }->($hash);
output
value
I assume none of the nested hashes have more than a single element?
A simple iteration is all that's necessary
use strict;
use warnings;
use 5.010;
my #hashes = (
{ 'known' => { 'a' => { 'b' => 'value1' } } },
{ 'known' => { 'a' => { 'b' => { 'c' => 'value2' } } } },
{ 'known' => { 'a' => { 'b' => { 'c' => { 'd' => 'value3' } } } } },
);
say get_value($_) for #hashes;
sub get_value {
my ($hash) = #_;
($hash) = values %$hash while ref $hash eq 'HASH';
$hash;
}
output
value1
value2
value3
Below is my Code with the Hash
#!/usr/bin/perl
use warnings;
use JSON::PP; # Just 'use JSON;' on most systems
my %name = (
'sl' => {
'fsd' => {
'conf' => {
'ul' => '/sl/fsd/conf/ul',
'si' => '/sl/fsd/conf/si',
'ho1' => '/sl/fsd/conf/ho1'
}
}
},
're' => {
'fsd' => {
'cron' => {
'README' => '/re/fsd/cron/README'
},
'bin' => {
'db' => {
'smart.p_add_tag' => '/re/fsd/bin/db/smart.p_add_tag',
'smart.p_tag_partition' => '/re/fsd/bin/db/smart.p_tag_partition',
'smart.p_add_tag_type' => '/re/fsd/bin/db/smart.p_add_tag_type'
}
},
'doc' => {
'SMART' => '/re/fsd/doc/SMART',
'README' => '/re/fsd/doc/README'
},
'data' => {
'README' => '/re/fsd/data/README'
},
'conf' => {
'al1' => '/re/fsd/conf/al1',
'file' => '/re/fsd/conf/file',
'ho' => '/re/fsd/conf/ho',
'al3' => '/re/fsd/conf/al3',
'hst' => '/re/fsd/conf/hst',
'us' => '/re/fsd/conf/us',
'README' => '/re/fsd/conf/README',
'al2' => '/re/fsd/conf/al2'
}
}
}
);
(my $root) = keys %name;
my %nodes = ();
my %tree = ();
my #queue = ($root);
list_children(\%name, \#queue, \%nodes) while #queue;
my $tree = build_tree($root, \%nodes);
my $json = JSON::PP->new->pretty; # prettify for human consumption
print $json->encode($tree);
sub list_children {
my $adjac = shift;
my $queue = shift;
my $nodes = shift;
my $node = shift #$queue;
my #children = keys %{$adjac->{$node}};
#children = grep { ! exists $nodes->{$_}} #children;
$nodes->{$node} = \#children;
push #$queue, #children;
}
sub build_tree {
my $root = shift;
my $nodes = shift;
my #children;
for my $child (#{$nodes->{$root}}) {
push #children, build_tree($child, $nodes);
}
my %h = ('text' => $root,
'children' => \#children);
return \%h;
}
I'm trying to output JSONified hash, but it is only traversing upto two levels. whereas i need it to traverse all upto the last child node of each parent. Can someone please help to achieve this.
Below is current output
{
"text" : "sl",
"children" : [
{
"text" : "fsd",
"children" : []
}
]
}
Normally, transforming the hash, and then json-ing is not the most efficient idea, because you're going to make one traversal to transform the hash and JSON's going to make one to json-ify it, and JSON is a type of transform of a hash.
However, JSON is usually done with XS, which means that the second traversal is faster, at least. That and JSON behavior is standardized.
use 5.016;
use strict;
use warnings;
use Data::Dumper ();
use JSON;
my $hash
= {
'Foods' => {
'fruits' => {
'orange' => '1',
'apple' => '2',
},
'Vegetables' => {
'tomato' => '3',
'carrot' => '1',
'cabbage' => '2',
}
}
};
sub descend {
my ( $structure, $block ) = #_;
my $res;
while ( my ( $k, $v ) = each %$structure ) {
$block->( $structure, $k, $v );
if ( ref( $v ) eq 'HASH' ) {
$res = descend( $v, $block );
}
}
return $res;
}
my $new = {};
my $curr = $new;
descend( $hash => sub {
my ( $lvl, $k, $v ) = #_;
my $node = { text => $k };
$curr->{children} //= [];
push $curr->{children}, $node;
if ( ref( $v ) eq 'HASH' ) {
$curr = $node;
}
else {
$node->{children} = { text => $v };
}
});
# allow for the root-level special case, and retrieve the first child.
$new = $new->{children}[0];
say Data::Dumper->Dump( [ $new ], [ '$new' ] );
say JSON->new->encode( $new );
Having a simple example code
use Modern::Perl;
use Data::Dumper;
package My;
use Moose;
use Method::Signatures::Simple;
has 'result' => (
is => 'rw',
isa => 'HashRef',
default => sub{{}},
clearer => 'clear_result'
);
method run {
$self->clear_result; #clearing the result
$self->result( $self->run_part1 );
$self->do_something;
$self->result( $self->run_part3 ); #need merge
}
method do_something {
$self->result( $self->run_part2 ); #need merge
}
method run_part1 { return { aaa => 'aaa' } }
method run_part2 { return { bbb => 'bbb' } }
method run_part3 { return { ccc => 'ccc' } }
package main;
my $p = My->new;
say Dumper $p->run;
the result (ofcourse) is:
$VAR1 = {
'ccc' => 'ccc'
};
I want the result:
$VAR1 = {
'aaa' => 'aaa'
'bbb' => 'bbb'
'ccc' => 'ccc'
};
so, the question is - how to merge the $self->result HashRef when setting it?
Yes, i can add new method add_result like:
method add_result($hr) {
use Hash::Merge::Simple qw(merge);
$self->result( merge $self->result, $hr );
}
and change everywhere in my code the $self->result to $self->add_result but wonder if there is another solution...
has 'result' => (
acccessor => '_result',
isa => 'HashRef',
default => sub{{}},
clearer => 'clear_result'
);
sub result {
my $self = shift;
if (#_) {
my ($hr) = #_;
return $self->_result( ... merged hash ...);
} else {
return $self->_result();
}
}
In Perl Tkx I created my own popups which work great.
But I would like to embed those built-in icons, like info, question.
Does anyone know how I can do that on my own widgets and how?
sub PopDialog {
my ($TITLE, $NOTE, #buttons) = #_;
my (#butt, $ret);
my $wait = 1;
my $xwm = Tkx::widget->new(".");
my $popwm = $xwm->new_toplevel();
$popwm->g_wm_title("$TITLE");
$popwm->g_wm_minsize(200, 10);
$popwm->g_wm_resizable(0, 0);
my $back = $popwm->new_ttk__frame(-padding => "5 5 5 5");
$back->g_grid(-column => 0, -row => 0, -sticky => "n");
$popwm->g_grid_columnconfigure(0, -weight => 1);
$popwm->g_grid_rowconfigure(0, -weight => 1);
if ($NOTE !~ /^$/) {
my $frm0 = $back->new_ttk__frame(-padding => 5);
my $label = $frm0->new_ttk__label(-text => "$NOTE", -font => 'logo_font')->
g_grid(-column => 0, -row => 0);
$frm0->g_pack();
}
my $frm1 = $back->new_ttk__frame(-padding => 5);
for my $x (0 .. $#buttons) {
$butt[$x] = $frm1->new_ttk__button(
-text => "$buttons[$x]",
-underline => 0,
-command => sub { $ret = "$buttons[$x]"; $wait = 0; }
)->g_grid(-column => $x, -row => 0);
}
$frm1->g_pack();
$popwm->g_wm_protocol(WM_DELETE_WINDOW => sub { $ret = "Exit"; $wait = 0; }); # Close Button returns "Exit"
$popwm->g_bind('<Unmap>', sub { $popwm->g_wm_deiconify; $xwm->g_focus; }); # No minimizing to Icon Allowed
while ($wait) {
Tkx::update();
$popwm->g_focus;
}
$popwm->g_destroy;
return $ret;
}