We have a sample code like below. Is it possible to to capture all missing attributes invoked in package FooBar and create it dynamically? This is something like PHP's __call.
test.pl
package Person;
use feature qw(say);
use Moo;
has name => (is => "ro");
my $p = Person->new(name => "John");
say $p->name;
# The missing attribute method will be dynamically created when
# invoked even it's not declared in Person.
say $p->lalala;
$ perl test.pl
John
Can't locate object method "lalala" via package "Test" at test.pl line 13.
It's possible using AUTOLOAD and metaprogramming, the question remains Why.
There might be nicer ways using parameterized roles, but I just wanted to quickly show how to do it. I would reject such code in a review (I'd expect at least a comment explaining why autoloading is needed).
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
{ package MyObj;
use Moose;
sub AUTOLOAD {
my ($self) = #_;
( my $method = our $AUTOLOAD ) =~ s/.*:://;
(ref $self)->meta->add_attribute($method, is => 'rw');
goto &$method
}
}
say 'MyObj'->can('lalala'); # No, it can't.
my $o = 'MyObj'->new;
$o->lalala(12); # Attribute created.
say $o->lalala; # 12.
Update: Previously, my code was more complex, as it replied to #simbabque's comment to the question: it showed how to add the attribute to an instance, not the whole class.
Related
While following this tutorial
https://www.codeproject.com/Articles/3152/Perl-Object-Oriented-Programming
I am failing to see where module Address.pm is.. did I miss something or article has an error or do I have a misunderstanding when one of the module says ' use Address ';
mac1:moduleTEST1 user1$ ./Employee.pl
Can't locate object method "new" via package "Address" (perhaps you forgot to load "Address"?) at ./Employee.pl line 16.
mac1:moduleTEST1 user1$
The tutorial is outdated and rather useless. Specifically, it is much worse than the documentation which comes with Perl. Use perldoc perltoc to get a table of contents, and read everything at least once.
See perldoc perlootut and perldoc perlobj.
package Address;
use strict;
use warnings;
sub new {
my $class = shift;
my $args = shift;
my %self = map +($_ => $args->{$_}), qw( street city state zip );
bless \%self => $class;
}
sub street {
my $self = shift;
if ( #_ ) {
$self->{street} = $_[0];
return;
}
return $self->{street};
}
# ditto for the rest of the accessors # there are
# ways to cut down the boilerplate once you learn
# the basics
#
# ...
__PACKAGE__
__END__
You use this module like this:
my $address = Address->new({
street => '123 E. Any St',
city => 'Any Town',
state => 'AY',
zip => '98765',
});
Of course, there a lot of things missing from this little demo. For example, the accessor, as written, allows you to change the state of the object. Immutable objects are easier to reason about, so you might want to disallow that by changing it to:
sub street { $_[0]->{street} }
It also allows you to assign any value you want to fields like state and zip. So, you may want to validate those values in the constructor, ensure that only values for the fields of the class are passed, all the values passed are defined etc.
At the end of that process, you may decide it doesn't make sense to keep writing boilerplate and use Moo or Moose to avail yourself to a richer set of features.
Even then, it helps to know what's happening under the hood.
I am getting an error when using Rose::DB.
#MyApp/DB.pm
package MyIMDB::DB;
use strict; use warnings;
use base qw(Rose::DB);
__PACKAGE__->use_private_registry;
__PACKAGE__->register_db (
driver => 'SQLite',
....
);
1;
# MyApp/DB/Object.pm
package MyApp::DB::Object;
use strict; use warnings;
use MyApp::DB;
use base qw(Rose::DB::Object);
sub init_db { MyIMDB::DB->new }
1;
#
package MyApp::Users; #controller
use strict; use warnings;
use base 'Mojolicious::Controller';
use Mojo::ByteStream 'b';
use MyApp::Models::User;
use Data::Dumper;
sub my_action {
my $uc = shift;
my $err = MyApp::Models::User::->validate(...); #extra ::
# http://perldoc.perl.org/perlobj.html#Invoking-Class-Methods
}
# MyApp/Models/User.pm # 2 packages in this file
package MyApp::Models::User::Manager;
use base qw(Rose::DB::Object::Manager);
use MyApp::Models::User;
sub object_class { 'MyApp::Models::User'}
__PACKAGE__->make_manager_methods('users');
# class methods get_x, get_x_iterator, get_x_count, delete_x, update_x
1;
MyApp::Models::User
use strict; use warnings;
use base qw(MyApp::DB::Object);
__PACKAGE__->meta->setup(
#setup tables, columns....
);
sub validate {
my $u = shift;
my $n = MyApp::Models::User::Manager::->get_users_count(query => [user_name => $user]);
}
1;
The error I get is:
"Can't use string ("MyApp::Models::User") as a HASH ref while "strict refs"
in use at /usr/local/share/perl/5.18.2/Rose/DB/Object.pm line 91, <DATA> line 2231."
The entry point is my_action() method of MyApp:Users class.
I tried alternative setups of creating class MyApp::Models::User::Manager : separate .pm file, make_manager_class(), but to no avail.
(I found this discussion from 2007 with the same error message, but it does not help me out http://comments.gmane.org/gmane.comp.lang.perl.modules.dbi.rose-db-object/1537).
This may indicate I am trying to call an object method as if it were a class method. I tried the tricks listed here http://perldoc.perl.org/perlobj.html#Invoking-Class-Methods, but no success.
I now I can examine the contents of variables with Data::Dumper, but I have no clue what to dump as there are very little data structures used.
While use strict is a good idea when writing Perl code, you may want to relax the strict-ness by adding
no strict `refs`;
to get past the current error. As #ikegami pointed out another way to fix this is to get rid of the bad reference, but if you don't want to rewrite the module working around it with relaxing strict-ness is your best bet.
I have a module that refuses to load unless a compile-time sanity check is met. Something like this:
package TopSecret;
use Moose;
die "Only Joe can use this!" unless $ENV{USER} eq 'joe';
1;
Now I would like to apply a similar sanity check to multiple modules, so my thought is to put it in a role. The consuming module would provide some information to customize the check a bit. So it might look something like:
package TopSecret;
use Moose;
with 'ForAuthorizedUser';
sub authorized_user { 'joe' }
1;
The problem is: how can I exercise TopSecret::authorized_user() from within ForAuthorizedUser, at compile time? Something like 'requires "authorized_user"' - except it would have to verify not just that the method exists, but execute it and check the return value.
I think that attribute overriding would be appropriate here. You declare the attribute in your Role and mark it as required, but don't provide a definition. Then the module that consumes the Role can supply the value for that attribute. Note that validation is typically done in the BUILD() subroutine.
package ForAuthorizedUser;
use Moose::Role;
use Carp qw(croak); # so you can see the line it fails on
has 'authorized_user' => (
is => 'ro',
required => 1,
);
sub BUILD {
my ($self) = #_;
croak "Only Joe can use this!"
unless $self->authorized_user eq 'joe';
}
1;
Now in your module that consumes ForAuthorizedUser, you supply the definition for the attribute:
package TopSecret;
use Moose;
with qw(ForAuthorizedUser);
has '+authorized_user' => (
default => 'joe',
);
__PACKAGE__->meta->make_immutable;
In a separate module you do the same thing, but with a different name (mine):
package TopSecret2;
use Moose;
with qw(ForAuthorizedUser);
has '+authorized_user' => (
default => 'hunter',
);
__PACKAGE__->meta->make_immutable;
Then you could test this like so:
use TopSecret;
use TopSecret2;
TopSecret->new; # lives
TopSecret2->new # croaks Only Joe can use this! at constructor TopSecret2::new (defined at Test.pm line 35) line 36.
I am trying to Iterate directories in Perl, getting introspectable objects as result, mostly so I can print fields like mtime when I'm using Dumper on the returns from IO::All.
I have discovered, that it can be done, if in the module IO::All::File (for me, /usr/local/share/perl/5.10.1/IO/All/File.pm), I add the line field mtimef => undef;, and then modify its sub file so it runs $self->mtimef($self->mtime); (note, this field cannot have the same name (mtime) as the corresponding method/property, as those are dynamically assigned in IO::All). So, in essence, I'm not interested in "overloading", as in having the same name for multiple function signatures - I'd want to "replace" or "override" a class with its extended version (not sure how this is properly called), but under the same name; so all other classes that may use it, get on to using the extended version from that point on.
The best approach for me now would be, if I could somehow "replace" the IO::All::File class, from my actual "runnable" Perl script -- if somehow possible, by using the mechanisms for inheritance, so I can just add what is "extra". To show what I mean, here is an example:
use warnings;
use strict;
use Data::Dumper;
my #targetDirsToScan = ("./");
use IO::All -utf8 ; # Turn on utf8 for all io
# try to "replace" the IO::All::File class
{ # recursive inheritance!
package IO::All::File;
use IO::All::File -base;
# hacks work if directly in /usr/local/share/perl/5.10.1/IO/All/File.pm
field mtimef => undef; # hack
sub file {
my $self = shift;
bless $self, __PACKAGE__;
$self->name(shift) if #_;
$self->mtimef($self->mtime); # hack
return $self->_init;
}
1;
}
# main script start
my $io = io(#targetDirsToScan);
my #contents = $io->all(0); # Get all contents of dir
for my $contentry ( #contents ) {
print Dumper \%{*$contentry};
}
... which fails with "Recursive inheritance detected in package 'IO::All::Filesys' at /usr/local/share/perl/5.10.1/IO/All/Base.pm line 13."; if you comment out the "recursive inheritance" section, it all works.
I'm sort of clear on why this happens with this kind of syntax - however, is there a syntax, or a way, that can be used to "replace" a class with its extended version but of the same name, similar to how I've tried it above? Obviously, I want the same name, so that I wouldn't have to change anything in IO::All (or any other files in the package). Also, I would preferably do this in the "runner" Perl script (so that I can have everything in a single script file, and I don't have to maintain multiple files) - but if the only way possible is to have a separate .pm file, I'd like to know about it as well.
So, is there a technique I could use for something like this?
Well, I honestly have no idea what is going on, but I poked around with the code above, and it seems all that is required, is to remove the -base from the use IO::All::File statement; and the code otherwise seems to work as I expect it - that is, the package does get "overriden" - if you change this snippet in the code above:
# ...
{ # no more recursive inheritance!? IO::All::File gets overriden with this?!
package IO::All::File;
use IO::All::File; # -base; # just do not use `-base` here?!
# hacks work if directly in /usr/local/share/perl/5.10.1/IO/All/File.pm
field mtimef => undef; # hack
sub file {
my $self = shift;
bless $self, __PACKAGE__;
$self->name(shift) if #_;
$self->mtimef($self->mtime); # hack
print("!! *haxx0rz'd* file() reporting in\n");
return $self->_init;
}
1;
}
# ...
I found this so unbelievable, I even added the print() there to make sure it is the "overriden" function that runs, and sure enough, it is; this is what I get in output:
...
!! *haxx0rz'd* file() reporting in
$VAR1 = {
'_utf8' => 1,
'mtimef' => 1394828707,
'constructor' => sub { "DUMMY" },
'is_open' => 0,
'io_handle' => undef,
'name' => './test.blg',
'_encoding' => 'utf8',
'package' => 'IO::All'
};
...
... and sure enough,the field is there, as expected, too...
Well - I hope someone eventually puts a more qualified answer here; for the time being, I hope this is as good as a fix to my problems :) ...
I'm trying to create a module with a method that receives a subroutine and redefines it. I had no problem redefining a subroutine inside the main script but the same syntax doesn't seem to work inside the method:
main.pl
use strict;
use warnings;
use ReDef;
sub orig{
print "Original!\n";
}
orig;
*orig=sub{print "not Original!\n";};
orig;
ReDef::redef(\&orig);
orig;
ReDef.pm
package ReDef;
use strict;
use warnings;
sub redef {
my $ref=shift;
*ref = sub {print "Redefined!";}
}
1;
Test output:
perl main.pl
Original!
Subroutine main::orig redefined at main.pl line 9.
not Original!
not Original!
ReDef::redef() doesn't redefine. The way I see it, the *ref is a coderef and assigning to it another subroutine should change main::orig();
What is the correct syntax?
Your redef function should be like this:
package ReDef;
use strict;
use warnings;
sub redef {
my $ref = shift;
no warnings qw(redefine);
*$ref = sub { print "Redefined!" };
}
And you should NOT call it like this:
ReDef::redef(\&orig);
Instead, you must call it like this:
ReDef::redef(\*orig);
Why? When you call orig, you're looking up the name "orig" via the symbol table, so the redef function needs to be altering the symbol table, so that it can point that name to a different bit of code. Globrefs are basically pointers to little bits of symbol table, so that's what you need to pass to ReDef::redef.
As an analogy, imagine that when you want to know the date of the Battle of Lewes, your procedure is to go to the library, look in the catalogue for the shelf address of a book on 13th century English battles, go to that shelf, and look up the date... voila 14 May 1264! Now, imagine I want to feed you altered information. Simply defining a new coderef would be like putting a new book on the shelf: it won't trick you because the catalogue is still pointing you at the old book. We need to alter the catalogue too.
UPDATE
You can make this a little prettier using prototypes. Prototypes are not usually recommended, but this seems to be a non-evil use for them...
use strict;
use warnings;
sub ReDef::redef (*) {
my $ref = shift;
no warnings qw(redefine);
*$ref = sub { print "Redefined!\n" };
}
sub orig { print "Original!\n" }
orig;
ReDef::redef *orig; # don't need the backslash any more
orig;
This works for me:
use v5.16;
use strict;
use warnings;
package Redef;
sub redef {
my $ref = shift;
${$ref} = sub { say "Redefined!"; }
}
package main;
my $orig = sub { say "Original!"; };
Redef::redef(\$orig);
$orig->(); # Redefined!
Although it’s just a result of trial and error, I’d be happy to see better answers.
What maybe got you confused is the typeglob operator, *. In Perl you dereference using a sigil (${$scalar_ref}, #{$array_ref}) and the * operator is used for symbol table tricks – which could also be used in your case, see the answer by #tobyink.