How can I export a subroutine from a Moose package? - perl

How can I export a normal, non-OO subroutine from a Moose package? In a regular package, I'd do it with Exporter, #ISA and #EXPORT.

Moose is for building classes and roles. While you technically can also export functions, it's not necessarily the best idea.
Here's an example Moose class which also exports a function.
MyApp/Widget.pm
use v5.26;
use warnings;
package MyApp::Widget;
use Exporter qw( import );
our #EXPORT_OK = qw( is_widget );
use Moose;
use namespace::autoclean -except => 'import';
has name => ( is => 'ro', isa => 'Str', required => 1 );
sub is_widget {
my $object = shift;
blessed( $object ) and $object->isa( __PACKAGE__ );
}
__PACKAGE__->meta->make_immutable;
Here's how you might use it:
use v5.26;
use warnings;
use MyApp::Widget qw( is_widget );
my $w = 'MyApp::Widget'->new( name => 'Foo' );
say is_widget( $w );
say $w->is_widget;
Note that even though is_widget was intended an exportable function, it can also be called as a method! In this case, that's a feature rather than a bug, but often that will be an inconvenience.
A better idea might be to create two separate packages: one for your class and one for your exportable functions.
MyApp/Widget.pm
use v5.26;
use warnings;
package MyApp::Widget;
use Moose;
use namespace::autoclean;
has name => ( is => 'ro', isa => 'Str', required => 1 );
__PACKAGE__->meta->make_immutable;
MyApp/Util.pm
use v5.26;
use warnings;
package MyApp::Util;
use Exporter qw( import );
our #EXPORT_OK = qw( is_widget );
use Scalar::Util qw( blessed );
sub is_widget {
my $object = shift;
blessed( $object ) and $object->isa( 'MyApp::Widget' );
}
1;
And you'd call use your packages like this:
use v5.26;
use warnings;
use MyApp::Widget;
use MyApp::Util qw( is_widget );
my $w = 'MyApp::Widget'->new( name => 'Foo' );
say is_widget( $w );
Because the Moose class and the Exporter are now cleanly separated, you can no longer call $w->is_widget — it's entirely a function and no longer a method.

Related

How do I set a default FileHandle attribute with moose

You may infer from the question that this is my first Moose class.
How do I set an attribute FileHandle to *STDOUT?
This doesn't work.
has 'output' => (
is => 'rw',
isa => 'FileHandle',
default => sub { openhandle(*STDOUT) }
);
The output when run is:
Attribute (output) does not pass the type constraint because: Validation failed for 'FileHandle' with value *main::STDOUT
The documentation claims:
FileHandle accepts either an IO::Handle object or a builtin perl
filehandle (see "openhandle" in Scalar::Util).
What am I missing?
Thanks.
-E
I don't know what else you may need there, but this works for starters
The WithFH.pm
package WithFH;
use feature 'say';
use Moose;
has 'fh' => (is => 'ro', isa => 'FileHandle', default => sub { \*STDOUT } );
sub say {
my $self = shift;
say { $self->{fh} } "#_";
}
__PACKAGE__->meta->make_immutable;
1;
and the main
use warnings;
use strict;
use feature 'say';
use WithFH;
my $wfh = WithFH->new;
$wfh->say("hi");
That prints hi to STDOUT.

Perl Storable retrieve an array of Moose Objects

I tried to store an array of Moose Objects to YAML or JSON.
The saving works very well, but when I try to restore my Objects, they're empty:
$VAR1 = bless({}, 'Note');
$VAR2 = bless({}, 'Note');
Here is my code:
Note.pm:
package Note;
use strict;
use warnings;
use Moose;
use MooseX::Storage;
with Storage('format' => 'JSON', 'io' => 'File');
has 'message' =>(is=> 'rw', isa =>'Str');
1;
testNote.pl:
use strict;
use warnings;
use utf8;
use feature 'say';
use Note;
use Storable;
use MooseX::Storage;
use Data::Dumper;
use JSON;
my #container=();
my $obj = Note->new;
$obj->message("firstmessage");
say $obj->message;
push(#container,$obj);
my $obj2 = Note->new;
$obj2->message("secondmessage");
push(#container,$obj2);
my #output=();
for my $counter (0 .. $#container){
push(#output,$container[$counter]->pack());
}
say "Output packed strings:" ;
for my $counter(0 .. $#output){
say $output[$counter];
}
store \#output, 'saveNotes';
my #Notes=();
my #fin=#{retrieve('saveNotes') };
say "After reading file:";
#Arr=();
for my $counter (0 .. $#fin){
push(#Arr,Note->unpack($fin[$counter]));
}
say Dumper(#Arr);
Hope someone could help :)

How do you print exported module constants in Perl?

I want to define some constants in one package and then use them in another package, but I don't seem to be doing this right! At first shot I was getting
Bareword "FAVORITE_COLOR" not allowed while "strict subs" in use at ...
I guess it was because I wasn't using the base path for my package in the lib() function,
Module
My/Colors.pm
package My::Colors;
BEGIN {
use Exporter;
our($VERSION, #ISA, #EXPORT, #EXPORT_OK, %EXPORT_TAGS);
$VERSION = 1.00;
#ISA = qw(Exporter);
#EXPORT = qw( );
#EXPORT_OK = qw( FAVORITE_COLOR DISLIKED_COLOR );
%EXPORT_TAGS = ( 'all' => [ #EXPORT, #EXPORT_OK ], 'const' => [ 'FAVORITE_COLOR', 'DISLIKED_COLOR'] );
}
our #EXPORT_OK;
use lib qw( /home/dev );
use Carp;
use constant {
DISLIKED_COLOR => "green",
FAVORITE_COLOR => "red"
};
sub new {
my($class, %args) = #_;
my $self = bless({}, $class);
my $target = exists $args{target} ? $args{target} : "new";
$self->{target} = $target;
return $self;
}
1;
Module that includes exported constants
color_driver.plx
#!/usr/bin/perl -w
use warnings;
use strict;
use diagnostics;
use lib qw( /home/dev/My );
use Colors;
use Colors qw(:const);
sub main{
my $color = new Colors;
print "Color is",FAVORITE_COLOR;
}
main();
any idea what I'm doing wrong?
When I remove strict the constant doesnt translate to its value =/
Updated
Unfortunately now perl is complaining that it can't find new sub
Can't locate object method "new" via package "Colors" (perhaps you
forgot to
load "Colors"?) at color_driver.plx line 15 (#1)
In the module:
package My::Colors;
In the script:
use lib qw( /home/dev/My );
use Colors qw(:const);
my $color = new Colors;
Either change those lines of the module to
package Colors;
or change those lines of the script to
use lib qw( /home/dev );
use My::Colors qw(:const);
my $color = new My::Colors;
use Colors qw( :const );
is almost identical to
BEGIN {
require Colors;
Colors->import(qw( :const ));
}
You are telling Perl to look in the Colors package/namespace for import (and new), but the module populates the package/namespace My::Colors.

Perl library to avoid redefining an already defined function

I have two perl module files like :
is_date_holiday.pl :
use strict;
use warnings;
sub IsDateHoliday
{
...
}
1
calc_prev_working_date_mult.pl :
use strict;
use warnings;
require "is_date_holiday.pl"; # IsDateHoliday
sub CalcPrevWorkingDateMult
{
...
}
1
On using them both in a perl file like :
require "is_date_holiday.pl"; # IsDateHoliday
require "calc_prev_working_date_mult.pl" # CalcPrevWorkingDateMult
It complains that I am redefining the function IsDateHoliday
How can do an equivalent of #ifndef ?
You don't actually have modules, but you should.
IsDateHoliday.pm:
package IsDateHoliday;
use strict;
use warnings;
use Exporter qw( import );
our #EXPORT_OK = qw( IsDateHoliday );
our %EXPORT_TAGS = ( all => \#EXPORT_OK );
sub IsDateHoliday
{
...
}
1;
CalcPrevWorkingDateMult.pm:
package CalcPrevWorkingDateMult;
use strict;
use warnings;
use Exporter qw( import );
our #EXPORT_OK = qw( CalcPrevWorkingDateMult );
our %EXPORT_TAGS = ( all => \#EXPORT_OK );
use IsDateHoliday qw( :all );
sub CalcPrevWorkingDateMult
{
...
}
1;
main.pl:
use IsDateHoliday qw( :all );
use CalcPrevWorkingDateMult qw( :all );
Really you should create packages for these and then use them. That will eliminate the issues with redefining because you can then import what you need and use won't import stuff twice.
package IsDateHoliday;
use strict;
use warnings;
use Exporter;
our #ISA = qw(Exporter);
our #EXPORT = qw(IsDateHoliday);
sub IsDateHoliday {
#...
}
1; # not a typo, Perl needs modules to return true
Name the file "IsDateHoliday.pm" then when you need it:
use strict;
use lib '.'; # to include the local directory
use IsDateHoliday;
Same treatment for the other one.
Of course one might question why you don't just use Date::Calc from CPAN. (Might not have holidays but I'm sure something else on CPAN does!)
Although it'd be best to change to use over require, which will check to see if it's already been loaded first, if you really wanted to write C in perl, likely the closest to what you're trying to do would be to just set some variable, and check to see if exists, but you have to hide the subroutine definition in an eval.
# in the included file:
my $DateHolidayLoaded;
if ( !$DateHolidayLoaded ) {
eval {
sub IsDateHoliday { ... }
$DateHolidayLoaded = 1;
};
}
You can test for a function's existance, too, but you have to specify what namespace to use ... and in this case, it'd be 'main' :
if ( ! defined( main->can( 'IsDateHoliday' ) ) ) { require 'is_date_holiday.pl' }
But this will only work in the file doing the include; if you do this test in a file with the subroutine definition, it'll always be true.

How to make the Moose constructor die on being passed an undeclared attribute?

Moose is very tolerant by default. You can have a class named Cucumber and pass an undeclared attribute (like wheels) to the constructor. Moose won't complain about that by default. But I might prefer Moose to rather die than accept undeclared attributes. How can I achieve that? I seem to remember having read it is possible but cannot find the place where it says so in the docs.
package Gurke;
use Moose;
has color => is => 'rw', default => 'green';
no Moose;
__PACKAGE__->meta->make_immutable;
package main; # small test for the above package
use strict;
use warnings;
use Test::More;
use Test::Exception;
my $gu = Gurke->new( color => 'yellow' );
ok $gu->color, 'green';
if ( 1 ) {
my $g2 = Gurke->new( wheels => 55 );
ok ! exists $g2->{wheels}, 'Gurke has not accepted wheels :-)';
# But the caller might not be aware of such obstinate behaviour.
diag explain $g2;
}
else {
# This might be preferable:
dies_ok { Gurke->new( wheels => 55 ) } q(Gurken can't have wheels.);
}
done_testing;
Okay, here's the updated test illustrating the solution:
package Gurke;
use Moose;
# By default, the constructor is liberal.
has color => is => 'rw', default => 'green';
no Moose;
__PACKAGE__->meta->make_immutable;
package Tomate;
use Moose;
# Have the Moose constructor die on being passed undeclared attributes:
use MooseX::StrictConstructor;
has color => is => 'rw', default => 'red';
no Moose;
__PACKAGE__->meta->make_immutable;
package main; # small test for the above packages
use strict;
use warnings;
use Test::More;
use Test::Exception;
my $gu = Gurke->new( color => 'yellow' );
ok $gu->color, 'green';
my $g2 = Gurke->new( wheels => 55 );
ok ! exists $g2->{wheels}, 'Gurke has not accepted wheels :-)';
diag 'But the caller might not be aware of such obstinate behaviour.';
diag explain $g2;
diag q(Now let's see the strict constructor in action.);
my $to = Tomate->new( color => 'blue' );
diag explain $to;
dies_ok { Tomate->new( wheels => 55 ) } q(Tomaten can't have wheels.);
done_testing;
Just use MooseX::StrictConstructor in your class; it's a metaclass trait that already does exactly what you want.