i am switching my application from Perl 5.8.8 to Perl 5.16.3 and now i get tons of warnings about the following third party code in SOAP::Lite
unless (defined %{"$protocol_class\::Client::" )
The code produces the following warings:
Warning in Perl code: \t(Maybe you should just omit the defined()?)
Warning in Perl code: defined(%hash) is deprecated at /.../SOAP/Lite.pm
line ...
If i reduce it to a simple example it looks like
unless( defined %{"some::string"} )
Question: Why should someone interpret a string "some::string" as a hash %{"some::string"} and check if the hash is defined? It doen't make any sense to me. I want to replace this codepiece with something else without breaking the third party module so i can focus on real important warnings and errors.
Here is the whole function. I don't know if this helps because think its some kind of Guru code which is a little bit hard to understand
sub proxy {
my $self = shift;
$self = $self->new() if not ref $self;
my $class = ref $self;
return $self->{_proxy} unless #_;
$_[0] =~ /^(\w+):/ or die "proxy: transport protocol not specified\n";
my $protocol = uc "$1"; # untainted now
# HTTPS is handled by HTTP class
$protocol =~s/^HTTPS$/HTTP/;
(my $protocol_class = "${class}::$protocol") =~ s/-/_/g;
no strict 'refs';
unless (defined %{"$protocol_class\::Client::"}
&& UNIVERSAL::can("$protocol_class\::Client" => 'new')
) {
eval "require $protocol_class";
die "Unsupported protocol '$protocol'\n"
if $# =~ m!^Can\'t locate SOAP/Transport/!;
die if $#;
}
$protocol_class .= "::Client";
return $self->{_proxy} = $protocol_class->new(endpoint => shift, #_);
}
The construct %Package:: gives access to a package's stash, i.e. the symbol table hash.
All this code is doing is checking whether a given package has been loaded (in which case its stash will exist) and that there is a new method for the package. If not then require is used to load the module.
The call to UNIVERSAL::can('package', 'method') is normally written as 'package'->can('method') and you can change that here if you like, but the code will work as it stands.
I suggest you do just as the warnings say, and omit the defined. It would also be nicer if you put the package name in its own variable instead of using the interpolated double-quoted string twice, and you can use the conventional call to can as I have described. It would look like this
my $package = "${protocol_class}::Client";
unless ( %{"${package}::"} and $package->can('new') ) {
# load missing module
}
Related
I tried to do something very fancy in Perl, and I think I'm suffering the consequences. I don't know if what I was trying to do is possible, actually.
My main program creates a pipe like this:
pipe(my $pipe_reader, my $pipe_writer);
(originally it was pipe(PIPE_READER, PIPE_WRITER) but I changed to regular variables when I was trying to debug this)
Then it forks, but I think that is probably irrelevant here. The child does this:
my $response = Response->new($pipe_writer);
The constructor of Response is bare bones:
sub new {
my $class = shift;
my $writer = shift;
my $self = {
writer => $writer
};
bless($self, $class);
return($self);
}
Then later the child will write its response:
$response->respond(123, "Here is my response");
The code for respond is as follows:
sub respond {
my $self = shift;
my $number = shift;
my $text = shift;
print $self->{writer} "$number\n";
print $self->{writer} "$text\n";
close $self->{writer}
}
This triggers a strange compile error: 'String found where operator expected ... Missing operator before "$number\n"?' at the point of the first print. Of course this is the normal syntax for a print, except that I have the object property instead of a normal handle AND it happens to be a pipe, not a file handle. So now I'm wondering if I'm not allowed to do this.
From print
If you're storing handles in an array or hash, or in general whenever you're using any expression more complex than a bareword handle or a plain, unsubscripted scalar variable to retrieve it, you will have to use a block returning the filehandle value instead, ...
print { $files[$i] } "stuff\n";
print { $OK ? *STDOUT : *STDERR } "stuff\n";
(my emphasis)
So you need
print { $self->{writer} } "$number\n";
Or, per Borodin's comment
$self->{writer}->print("$number\n");
The syntax of print is special, see for example this post and this post. For one, after print must come either a "simple" filehandle or a block evaluating to one, as quoted above, to satisfy the parser.
But with the dereference (arrow) operator the filehandle is found to be an IO::File object† and so its parent's IO::Handle::print method is invoked on it.
Prior to v5.14 there had to be use IO::Handle; for this to work, though not anymore. See this post and links in it for more.
Note that print FILEHANDLE LIST is not an indirect method call,
even as it may appear to be. It is just a function call to the print builtin under rather special syntax rules. It is only with an explicit ->
that an IO::Handle method gets called.
† It is either blessed into the class as the method call is encountered (and fails), or at creation; I can't find it in docs or otherwise resolve whether filehandles are blessed at creation or on demand
perl -MScalar::Util=blessed -wE'
pipe(RD,WR);
say *WR{IO}; #--> IO::File=IO(0xe8cb58)
say blessed(WR)//"undef"; #--> undef
'
(warns of unused RD) We can't do this with lexical filehandles as they are not in the symbol table.
But once needed a filehandle is an IO::File or IO::Handle object (depending on Perl version).
If I pass it as an argument I get the error:
'Can't locate object method "getline" via package "Bad" at Bad.pm line 27.'
But if I insert it in the module it works.
This is the boiled down code. bad.pl uses the module Bad.pm. Set $CAUSE_ERROR to see the problem.
#!/usr/bin/env perl
# This is bad.pl
use strict;
use warnings;
use IO::File;
use Bad; # use the bad module "Bad.pm"
&Main();
sub Main {
my $filename = "bad.pl";
warn "About to parse '$filename'\n";
my $MyWord = Bad->new(); # Create a new object.
my $io = IO::File->new($filename, "r");
#####################
my $CAUSE_ERROR = 1; # Set to 0 it does NOT cause an error. Set to 1 it DOES.
#####################
if($CAUSE_ERROR ) {
$MyWord->Parse($MyWord, $io);
} else {
$MyWord->{fd} = $io;
$MyWord->Parse($MyWord);
}
}
This is Bad.pm
package Bad;
# This is Bad.pm
use warnings;
use strict;
sub new {
my ($class, $args) = #_;
my $self = {
fd => undef,
};
return bless($self, $class); # Changes a function to a class
}
sub Parse {
my ($MyWord, $io) = #_;
if(defined($MyWord->{fd})){
# WORKS
$io = $MyWord->{fd};
while ( defined(my $inputline = $io->getline) ) {
print "${inputline}";
}
} else {
# FAILS
while ( defined(my $inputline = $io->getline) ) {
print "${inputline}";
}
}
}
1;
Using Perl v5.22.3 under Cygwin.
Originally I had Bad.pm in a sub directory but I simplified it.
Thank you for you time.
To summarize:
$MyWord->Parse($MyWord, $io);
Given that $MyWord is a reference blessed into the Bad class (i.e, it's an instance of Bad), this calls Bad::Parse with the arguments ($MyWord, $MyWord, $io). That is, it behaves as if you'd called:
Bad::Parse($MyWord, $MyWord, $io)`.
However, Bad::Parse() is written to expect the arguments ($MyWord, $io), so $io gets set to the second $MyWord, and Bad::Parse() throws an error when it tries to call $io->getline because the Bad module doesn't implement that method.
The fix is simple:
Call the function as $MyWord->Parse($io).
Change the variable name for the first argument in Bad::Parse() from $MyWord to $self. This isn't strictly necessary -- you can technically call this variable whatever you want -- but it's conventional, and will make your code much more readable to other Perl programmers.
To summarize errors in the posted code: The class name is passed to the constructor behind the scenes, as is the object to methods; we do not supply them. We do pass the filehandle to new, so that it is assigned to object's data and it can thus be used by methods in the class.
Here is a basic example. I try to stick to the posted design as much as possible. This does not do much of what is needed with I/O objects, but is rather about writing a class in general.
The class is meant to process a file, having been passed a filehandle for it. We expect to have one filehandle per object. Since we get it open the reponsibility to close it is left to the caller.
script.pl
use strict;
use warnings;
use feature 'say';
use IO::File;
use ProcessFile;
my $filename = shift || $0; # from command line, or this file
say "About to parse '$filename'";
my $io = IO::File->new($filename, "r") or die "Can't open $filename: $!";
my $word = ProcessFile->new($io); # Create a new object, initialize with $io
$word->parse();
# OR, by chaining calls
#my $word = ProcessFile->new($io)->parse();
say "Have ", ProcessFile->num_objects(), " open filehandles";
$io->close;
The package file ProcessFile.pm
package ProcessFile;
use warnings;
use strict;
use Carp qw(croak);
use Scalar::Util qw(openhandle);
# Example of "Class" data and methods: how many objects (open filehandles)
our $NumObjects;
sub num_objects { return $NumObjects }
sub DESTROY { --$NumObjects }
sub new {
my ($class, $fh) = #_; # class name, arguments passed to constructor
# To also check the mode (must be opened for reading) use Fcntl module
croak "No filehandle or not open or invalid " if not openhandle $fh;
my $self = { _fh => $fh }; # add other data that may make sense
bless $self, $class; # now $self is an object of class ProcessFile
++$NumObjects;
return $self;
}
sub parse {
my ($self, #args) = #_; # object, arguments passed to method (if any)
# Filehandle is retrieved from data, $self->{_fh}
while ( defined(my $inputline = $self->{_fh}->getline) ) {
print $inputline;
}
# Rewind before returning $self (or not, depending on design/#args)
# Can do more here, set some data etc, as needed by class design
seek $self->{_fh}, 0, 0;
return $self;
}
1;
A few comments on the above code follow. Let me know if more would be helpful.
Class data and methods don't belong to any one object, and are used for purposes that relate to the class as a whole (for example, to track all objects in play).
The DESTROY method runs when an object is destroyed, for example when it goes out of scope. Here we need it in order to decrease the count of existing objects. Try: place the code creating an object in a block { ... }; and see what count we get after the block.
We use openhandle from Scalar::Util to test whether the filehandle is open. We should really also test whether it is open for reading, since that is the fixed purpose of the class, using Fcntl.
In the sole, example method parse we read out the file and then rewind the filehandle, before returning the object. That is a placeholder for saving and/or setting the state for repeated use. What is done depends on the purpose and design of the class, and can be controlled by arguments.
Documentation: tutorial perlootut and reference perlobj on object-oriented work in Perl, perlmod for modules (a class is firstly a package), and a tutorial perlreftut for references.
There are also many informative SO posts around, please search.
Is it possible to get all valid methods for a particular Perl class?
I am trying to manipulate the symbol table of a class and get all of its methods. I found I can separate out the subroutines from the non-subroutines via the $obj->can($method), but that doesn't do exactly what I think it does.
The following returns:
subroutine, Property, croak, Group, confess, carp, File
However, subroutine isn't a method, (just a subroutine), and croak, confess, and carp were all imported into my package.
What I really want to print out is:
Property,Group, File
But I'll take:
subroutine, Property,Group, File
Below is my program:
#! /usr/bin/env perl
use strict;
use warnings;
use feature qw(say);
my $sections = Section_group->new;
say join ", ", $sections->Sections;
package Section_group;
use Carp;
sub new {
return bless {}, shift;
}
sub Add {
my $self = shift;
my $section = shift;
}
sub Sections {
my $self = shift;
my #sections;
for my $symbol ( keys %Section_group:: ) {
next if $symbol eq "new"; # This is a constructor
next if $symbol eq "Add"; # Not interested in this method
next if $symbol eq "Sections"; # This is it's own method
push #sections, $symbol if $self->can($symbol);
}
return wantarray ? #sections : \#sections;
}
sub subroutine {
my $param1 = shift;
my $param2 = shift;
}
sub Group {
my $self = shift;
my $section = shift;
}
sub File {
my $self = shift;
my $section = shift;
}
sub Property {
my $self = shift;
my $section = shift;
}
This is fairly trivial. We only want to keep those sub names that were originally defined in our package. Every CV (code value) has a pointer to the package where it was defined. Thanks to B, we can examine that:
use B ();
...
if (my $coderef = $self->can($symbol)) {
my $cv = B::svref_2object $coderef;
push #sections, $symbol if $cv->STASH->NAME eq __PACKAGE__;
}
# Output as wanted
That is, we perform introspection using svref_2object. This returns a Perl object representing an internal perl data structure.
If we look into a coderef, we get a B::CV object, which represents the internal CV. The STASH field in a CV points to the Stash where it was defined. As you know, a Stash is just a special hash (internally represented as a HV), so $cv->STASH returns a B::HV. The NAME field of a HV contains the fully qualified package name of the Stash if the HV is a Stash, and not a regular hash.
Now we have all the info we need, and can compare the wanted package name to the name of the stash of the coderef.
Of course, this is simplified, and you will want to recurse through #ISA for general classes.
Nobody likes polluted namespaces. Thankfully, there are modules that remove foreign symbols from the Stash, e.g. namespace::clean. This is no problem when the CVs of all subs you are calling are known at compile time.
What are you trying to do? Why does it matter how a class defined or implements a method it responds to?
Perl is a dynamic language, so that means that methods don't have to exist at all. With AUTOLOAD, a method might be perfectly fine and callable, but never show up in the symbol table. A good interface would make can work in those cases, but there might be cases where a class or an object decides to respond to that with false.
The Package::Stash module can help you find defined subroutines in a particular namespace, but as you say, they might not be defined in the same file. The methods in a class might come from an inherited class. If you care about where they come from, you're probably doing it wrong.
The autodie documentation hints that it is possible to use it for other functions than those built-ins which it can handle by default, but there are no clear examples how to do that in it.
Specifically I would like to use it for the Imager module. A lot of the functions and methods of that can fail, and I would prefer if that wouldn't mean that my code will be littered with or die Imager|$image->errstr; phrases all over.
Of course, if there's another way than using autodie to achieve that, I would be interested in that too.
autodie only works with functions, not methods. This is because it's lexically scoped, and method lookup can't be lexically scoped. autodie::hints explains how to tell autodie about user-defined functions, but that won't do anything for methods.
I don't know of any way to get autodie-like behavior for methods, unless the module has that built in (e.g. DBI's RaiseError).
You could have a subroutine to do the check, but it wouldn't save all that much code, since you'd still have to pass it the correct object or class to call errstr on.
See autodie::hints
Here is an alternative technique that works with methods:
package SafeCall;
use Carp ();
sub AUTOLOAD {
my ($method) = our $AUTOLOAD =~ /([^:']+)$/; #'
unshift #_, my $obj = ${shift #_};
my $code = $obj->can($method)
or Carp::croak "no method '$method' on $obj";
&$code or Carp::croak $obj->can('errstr')
? $obj->errstr
: "calling $method on $obj failed"
}
And to use it:
package Image;
sub new {bless {here => 'ok', also => 'can be looked up'}};
sub fails {$_[0]{not_here}}
sub succeeds {$_[0]{here}}
sub lookup {$_[0]{$_[1]}}
sub errstr {'an error occurred'}
package main;
use 5.010; # for say()
my $safe = sub {bless \$_[0] => 'SafeCall'};
# storing the constructor in the scalar $safe allows $safe to be used
# as a method: $obj->$safe->method
my $img = Image->new;
say $img->$safe->succeeds; # prints 'ok'
say $safe->($img)->succeeds; # or call this way (also prints 'ok')
say $img->$safe->lookup('also'); # prints 'can be looked up'
say $img->$safe->fails; # dies with 'an error occurred at file.pl line ##'
I'm using dynamic multilevel hashes from which I read data but also writes data.
A common pitfall for me is accessing non-existing keys (typos, db revisions etc.). I get undefs which propagate to other parts and cause problems. I would like to die whenever I try to read a non-existing key, but still be allowed to add new keys.
So the wanted behavior is:
my %hash;
$hash{A} = 5; # ok
print $hash{A}, "\n"; # ok
print $hash{X}, "\n"; # should die
$hash{B}{C}{D} = 10; # ok
print $hash{B}{C}{X}, "\n"; # should die
I previously posted a similar question and got great answers. I especially like the accepted one, which allows using the normal hash syntax. The only problem is I'm not sure how to easily generalize this to deep hashes as in the example above.
p.s.
I find this feature really useful and I wonder if I'm missing something, since it does not seem very popular. Perhaps it is not common to read/write from/to the same hash?
With warnings pragma switched on then you do get Use of uninitialized value in print at... warnings at the two lines you want to die.
So if you make warnings fatal then they would die instead:
use warnings FATAL => 'all';
Update
Based on comments you've made I assume your common case issue is something along these lines:
my $x = $hash{B}{C}{X};
Which won't throw warning/error until you actually use $x later on.
To get around this then you can do:
my $x = $hash{B}{C}{X} // 'some default value';
my $z = $hash{B}{C}{Z} // die "Invalid hash value";
Unfortunately the above would mean a lot of extra typing :(
Here is at least a short cut:
use 5.012;
use warnings FATAL => 'all';
use Carp 'croak';
# Value Or Croak!
sub voc { $_[0] // croak "Invalid hash" }
Then below would croak!
my $x = voc $hash{B}{C}{X};
Hopefully this and also the fatal warnings are helpful to you.
/I3az/
It's late for me so I'll be brief, but you could do this using the tie functionality -- have your hash represented by an object underneath, and implement the functions needed to interact with the hash.
Check out perldoc -f tie; there are also many classes on CPAN to look at, including Tie::Hash itself which is a good base class for tied hashes which you could build on, overriding a few methods to add your error checking.
If you want to wrap checks around a hash, create a subroutine to do it and use it as your interface:
use 5.010;
use Carp qw(croak);
sub read_from_hash {
my( $hash, #keys ) = #_;
return check_hash( $hash, #keys ) // croak ...;
}
But now you're starting to look like a class. When you need specialized behavior, start writing object-oriented classes. Do whatever you need to do. That's the part you're missing, I think.
The problem with sticking to the hash interface is that people expect the hash syntax to act as normal hashes. When you change that behavior, other people are going to have a tough time figuring out what's going on and why.
If you don't know what keys the hash might have, use one of the tied hash suggestions or just turn on warnings. Be aware that tying is very slow, nine times slower than a regular hash and three times slower than an object.
If you have a fixed set of possible keys, what you want is a restricted hash. A restricted hash will only allow you to access a given set of keys and will throw an error if you try to access anything else. It can also recurse. This is much faster than tying.
Otherwise, I would suggest turning your data into an object with methods rather than direct hash accesses. This is slower than a hash or restricted hash, but faster than a tied hash. There are many modules on CPAN to generate methods for you starting with Class::Accessor.
If your data is not fixed, you can write simple get() and set() methods like so:
package Safe::Hash;
use strict;
use warnings;
use Carp;
sub new {
my $class = shift;
my $self = shift || {};
return bless $self, $class;
}
sub get {
my($self, $key) = #_;
croak "$key has no value" unless exists $self->{$key};
return $self->{$key};
}
sub set {
my($self, $key, $value) = #_;
$self->{$key} = $value;
return;
}
You can get recursive behavior by storing objects in objects.
my $inner = Safe::Hash->new({ foo => 42 });
my $outer = Safe::Hash->new({ bar => 23 });
$outer->set( inner => $inner );
print $outer->get("inner")->get("foo");
Finally, since you mentioned db revisions, if your data is being read from a database then you will want to look into an object relation mapper (ORM) to generate classes and objects and SQL statements for you. DBIx::Class and Rose::DB::Object are two good examples.
Use DiveDie from Data::Diver:
use Data::Diver qw(DiveDie);
my $href = { a => { g => 4}, b => 2 };
print DiveDie($href, qw(a g)), "\n"; # prints "4"
print DiveDie($href, qw(c)), "\n"; # dies
re: your comment - hints on how to get the recursive effect on Ether's tie answer.
I'ts not for the fainthearted, but below is a basic example of one way that you might do what you're after by using Tie::Hash:
HashX.pm
package HashX;
use 5.012;
use warnings FATAL => 'all';
use Carp 'croak';
use Tie::Hash;
use base 'Tie::StdHash';
sub import {
no strict 'refs';
*{caller . '::hash'} = sub {
tie my %h, 'HashX', #_;
\%h;
}
}
sub TIEHASH {
my $class = shift;
croak "Please define a structure!" unless #_;
bless { #_ }, $class;
}
sub STORE {
my ($self, $key, $value) = #_;
croak "Invalid hash key used to store a value" unless exists $self->{$key};
$self->{$key} = $value;
}
sub FETCH {
my ($self, $key) = #_;
exists $self->{$key}
? $self->{$key}
: croak "Invalid hash key used to fetch a value";
}
1;
Above module is like a strict hash. You have to declare the hash structure up front then any FETCH or STORE will croak unless the hash key does exist.
The module has a simple hash function which is imported into calling program and is used to build the necessary tie for everything to work.
use 5.012;
use warnings;
use HashX;
# all my hashref are ties by using hash()
my $hash = hash(
a => hash(
b => hash(
c => undef,
),
),
);
$hash->{a}{b}{c} = 1; # ok
$hash->{a}{b}{c} = 2; # also ok!
$hash->{a}{b}{d} = 3; # throws error
my $x = $hash->{a}{b}{x}; # ditto
Remember this is a quick & dirty example and is untested beyond above. I'm hoping it will give you the idea of how it could be done using Tie::Hash and even whether it's worth attempting :)