package My::Module;
# $Id$
use strict;
use Carp;
use Data::Dumper;
use DBI;
$My::Module::VERSION = '0.1';
sub new {
my ($class, %opt) = #_;
my $opt_count = keys %opt;
$class->set_error('');
#return $class->set_error("Too many arguments to initialize.") if ($opt_count > 5);
#return $class->set_error("Missing arguments to initialize.") if ($opt_count < 2);
my $self = bless {
_DRIVER_OPTIONS => $opt{'mysql'},
},$class;
if (not defined $self) {
return $class->set_error( "new() failed: " . $class->errstr );
}
if ($self->{_DRIVER_OPTIONS}->{Host} ne '') {
$self->{_DRIVER_OPTIONS}->{DataSource} = 'DBI:mysql:database=' . $self->{_DRIVER_OPTIONS}->{Database} . ';host=' . $self->{_DRIVER_OPTIONS}->{Host};
} else {
$self->{_DRIVER_OPTIONS}->{DataSource} = 'DBI:mysql:database=' . $self->{_DRIVER_OPTIONS}->{Database} . ';';
}
$self->{Handle} = DBI->connect($self->{_DRIVER_OPTIONS}->{DataSource},
$self->{_DRIVER_OPTIONS}->{Username},
$self->{_DRIVER_OPTIONS}->{Password},
{ RaiseError=>1, PrintError=>1, AutoCommit=>1 }
);
return $self->set_error("new(): couldn't connect to database: " . DBI->errstr) unless ($self->{Handle});
$self->{_disconnect} = 1;
print Dumper \$self;
return $self;
}
sub database {
my $self = shift;
if (#_) { $self->{Handle} = shift }
return $self->{Handle};
}
sub set_error {
my $class = shift;
my $message = shift;
$class = ref($class) || $class;
no strict 'refs';
${ "$class\::errstr" } = sprintf($message || "", #_);
return;
}
*error = \&errstr;
sub errstr {
my $class = shift;
$class = ref( $class ) || $class;
no strict 'refs';
return ${ "$class\::errstr" } || '';
}
sub DESTROY {
my $self = shift;
unless (defined $self->{Handle} && $self->{Handle}->ping) {
$self->set_error(__PACKAGE__ . '::DESTROY(). Database handle has gone away');
return;
}
unless ($self->{Handle}->{AutoCommit}) {
$self->{Handle}->commit;
}
if ($self->{_disconnect}) {
$self->{Handle}->disconnect;
}
}
1;
Is that the right way so i can
re-use the database on my code
instead of having to open a new
connection or that will aswell open
a new connection every time i use it
?
Should i change anything on the
module ? or anything i did wrong ?
Currently i am just learning and thinked of doing my own engine module so i began with this.
Simple test code (the bellow code is not to be reviewed just a sample on how to use the module):
#!/usr/bin/perl
use warnings;
use strict;
use Data::Dumper;
use lib 'path to module';
use My::Module;
my $session = My::Module->new(mysql => {
Database =>'module',
Host =>'10.0.0.2',
Username =>'module',
Password =>'module'
}) or die My::Module->errstr;
my $dbh = $session->database();
my $sth = $dbh->prepare(q{
SELECT session_id
FROM sessions
});
$sth->execute() || die print($dbh->errstr);
my $ref = $sth->fetchall_arrayref({});
$sth->finish;
print Dumper \$ref;
I would suggest using an existing database interface rather than rolling your own, as there are many secret gotchas that others have spent years figuring out and solving for you. DBIx::Connector is excellent, and with its fixup mode, will let you reuse database connections, even across process forks.
Additionally, if you use Moose you will never have to write your own object constructors or object fields again. :)
DBIx::Class combined with Moose would be even better, but not necessary until you find yourself needing more ORM-ish features.
Other than using a CPAN module to accomplish this task, here are my practical recommendations:
Don't return an error value from the constructor. Instead, throw an exception.
Access the internals of your class using accessors rather than using direct hash access.
If the user of your class did not enable AutoCommit, she chose not to enable AutoCommit for a reason. Therefore don't do:
unless ($self->{Handle}->{AutoCommit}) {
$self->{Handle}->commit;
}
in DESTROY.
Note that bless is not going to fail so long as it is given a modifiable reference (compare this to, say, the behavior of open which can fail to open a file even though the argument to open is a valid filename and would indicate this situation by returning a false value). Therefore, checking the return value of bless does not serve any useful purpose. If you want to handle the possibility of bless failing, you will have to catch fatal runtime exceptions.
Your way of exposing errors is very, very oldfashioned. If something exceptional happens, why not raise a proper exception? You seem to have modelled your error handling after the DBI module. Note that DBI also has a RaiseError option. Using that is almost always more reasonable than using the oldfashioned errorstr version. Unfortunately DBI can't change it's default anymore now, but for new code I entirely don't see the reason to copy this flawed idea.
You're also constructing a DBI connection within your code, based on parameters the user provided from the outside. Do you have a good reason for doing that? Allowing the user to pass in the DBI::dh he constructed himself would be more flexible. Yes, that requires slightly more code on the outside to set up objects and wire them together, but it will also result in a cleaner design. If wiring up your objects manually bothers you too much, you might want to have a look at Bread::Board to do the wiring for you instead of compromising on the design of your module.
Also, I second Ether's suggestion of using DBIx::Connector. It really takes a lot of pain out of managing database handles, which can be very error-prone.
Related
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.
I need to instantiate a new $dbh using DBI.
My objects usually have a $dbh present when they're created.
When I try to create a new $dbh using
my $dbh = MyLib::Connect();
and after performing some DB operations doing
$dbh->disconnect();
my downstream code's $dbh is closed. Is there a way to get what I'm after? I've seen some example code that does two DBI->connect(...) calls but using the same code as an example produces the same result - it's like MyLib is caching the returned $dbh value.
Example code:
package MyLib;
sub DoConnect {
...
my $dbh = DBI->connect(...);
return($dbh)
}
package Object;
sub GetData {
my ($id) = #_;
my $dbh = MyLib::DoConnect(); # This should be separate
...
$dbh->commit()
$dbh->disconnect();
return($someData);
}
package AnotherObject;
sub DoSomething {
my ($self) = #_;
# $self had a dbh set on instantiation with MyLib::DoConnect();
my $newData = Object::GetData($self->id);
my $moreData = GetDataUsingDBH($self->dbh); # the dbh is closed!!!
}
Is what I need to do possible without starting a separate thread (which I can't guarantee will finish before GetDataUsingDBH is called). Should I do a system call to an external program to wait for it to finish? Does my question even make sense?
The approach you describe works fine.
package MyLib;
use DBI qw( );
sub DoConnect {
return DBI->connect(
'dbi:SQLite:foo.sqlite3', undef, undef,
{ PrintError=>0, RaiseError=>1 },
);
}
package Object;
sub new {
my $class = shift;
my $self = bless({}, $class);
return $self;
}
sub GetData {
my $dbh = MyLib::DoConnect();
$dbh->disconnect();
}
package AnotherObject;
sub new {
my $class = shift;
my $self = bless({}, $class);
$self->{dbh} = MyLib::DoConnect();
return $self;
}
sub DoSomething {
my ($self) = #_;
return $self->{dbh}->selectrow_array("SELECT 'abc'");
}
package main;
my $ao = AnotherObject->new();
my $o = Object->new();
$o->GetData();
print $ao->DoSomething(), "\n";
Output:
abc
Something else you didn't mention is causing the problems.
I figured it out. I setup my DBHs to be shared by all of my objects in the executable so I don't have to instantiate one DBH and pass it around to my objects manually - this ruined the behavior I was expecting when I actually needed to do this.
Thanks for all of your help, folks - learned a bunch.
Are you certain DoConnect is calling DBI->connect, not DBI->connect_cached, or something else that is caching database handles?
If so, I'm guessing you have Apache::DBI loaded and are running under mod_perl (or at any rate have $ENV{MOD_PERL} set), which causes DBI->connect to use Apache::DBI to cache connections.
You can tell DBI to not do this by calling connect with a dbi_connect_method attribute:
DBI->connect( $data_source, $username, $auth, {
'dbi_connect_method' => 'connect',
} );
(which would require you to pass something into your DoConnect saying that's what you want).
That is the documented way; an undocumented way that may work for you is to locally set the variable that DBI uses as the default for that attribute:
# This should be separate
my $dbh = do { local $DBI::connect_via = 'connect'; MyLib::DoConnect() };
(I guess it is possible even if you don't have $ENV{MOD_PERL} set when you load DBI that your code is already setting $DBI::connect_via to 'connect_cached' or some other package and that is causing your trouble.)
Another approach, if you don't actually need to use the two database handles at the same time, would be to just remove the disconnect call. When $dbh goes out of scope, if there are no other copies of that database handle around, it will be closed; explicitly calling disconnect isn't necessary.
I'm making a Perl module and I am still getting to grips with how Perl deals with objects.
This is the new sub that I wrote to create an object and I have no problem updating elements:
sub new {
my $class = shift;
my ($self) = {
name => undef
};
bless($self, $class);
return $self;
}
sub get_name {
my $self = shift;
$self->{name} = 'Eve';
return $self->{name};
}
I can use the object fine when I call the module and access it from another file, but I want to use the data in the object at other areas in the module code.
So I have no problem doing this:
my $new_object = new ProgramTest; # ProgramTest being the module/package
my $name = get_name();
But I want to use the $self elements in a 'module-internal' method which is never accessed by an outside script. So I want to have something like this:
sub get_variables {
return (name); # I don't know how to get the name here
# (I plan to have other variables, too)
}
I am probably missing something obvious (I'm sure I'll kick myself when I see the solution), so any help appreciated!
I want this so that the rest of the module can use the variables (without changing) as there are conditions that rely on their values.
There's no such thing as internal/private methods in perl objects. Common practise is to start any methods which should not be used publicly with an underscore, but this is not enforced in any way. Also have a look at moose - it takes a lot of the hassle out of OO perl.
With regards to your question the below shows how one module method can call another module method, with both having access to the object data. Again I woulds really recommend you use Moose!
sub publicSub{
my ( $self ) = #_;
return $self->_privateSub();
}
sub _privateSub{
my ( $self ) = #_;
return $self->{name};
}
I think you want class-variables. They are global to a class and all instances of the class (i.e. all the objects you created) can see them. Global in this case means that they are at the ouside-most lexical scope, so all subs can see them.
package ProgramTest;
my $everyone_can_see_this = 1; # lexical scope, but 'global' to the package
sub new {
my $class = shift;
my ($self) = {
name => undef
};
bless($self, $class);
return $self;
}
sub get_var {
my $self = shift;
return ++$everyone_can_see_this;
}
package Main;
my $o1 = ProgramTest->new;
my $o2 = ProgramTest->new;
say $o1->get_var;
say $o2->get_var;
say $o1->get_var;
__END__
2
3
4
But I don't see why you would want to do that. It doesn't make sense (unless you want an object-counter). Don't use it for config values, or you cannot really have objects for different purposes of the same class.
Maybe you want something else. If so, please try to rephrase your question.
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 :)
I've just started to learn about tie. I have a class named Link which I would like to do the following thing:
if fetched, return the link's address
if stored, store the new address
be able to call methods on it
So far, my code is :
package Link;
sub FETCH {
my $this = shift;
return $this->{"site"};
}
sub STORE {
my ($self,$site) = #_;
$self->{"site"} = $site;
}
sub print_method {
my $self = shift;
print $self->{"site"};
}
sub TIESCALAR {
my $class = shift;
my $link = shift;
my $this = {};
bless($this,$class);
$this->{"site"} = $link;
return $this;
}
1;
And the code I'm using to check the functionality is:
use Link;
tie my $var,"Link","http://somesite.com";
$var->print_method;
When ran, the script will terminate with the following error:
Can't call method "print_method" without a package or object reference at tietest.pl line 4..
If I understand its message correctly, $var->print_method resolves to some string upon which the method print_method is called. How could I benefit from tie, but also use the variable as an object?
EDIT: after experimenting a bit,I found out that if I return $self on fetch , I can call the methods , however , fetch won't return the address .
EDIT 2:the perl monks supplied me the solution : tied . tied will return a reference to the object VARIABLE .
By combining tied with my methods , I can accomplish everything I wanted .
Tie is the wrong tool for this job. You use ties when you want the same interface as normal data types but want to customize how the operations do their work. Since you want to access and store a string just like a scalar already does, tie doesn't do anything for you.
It looks like you want the URI module, or a subclass of it, and perhaps some overloading.
If you really need to do this, you need to use the right variable. The tie hooks up the variable you specify to the class you specify, but it's still a normal scalar (and not a reference). You have to use the object it returns if you want to call methods:
my $secret_object = tie my($normal_scalar), 'Tie::Class', #args;
$secret_object->print_method;
You can also get the secret object if you only have the tied scalar:
my $secret_object = tied $normal_scalar;
I have an entire chapter on tie in Mastering Perl.
I suggest making a normal Perl object and then overloading stringification. You lose the ability to store a value through assignment, but retain the ability to get the value out by printing the object. Once you start wanting to call methods directly, an object is probably what you want.
package Link;
use strict;
use Carp;
use overload
(
'""' => sub { shift->site },
fallback => 1,
);
sub new
{
my $class = shift;
my $self = bless {}, $class;
if(#_)
{
if(#_ == 1)
{
$self->{'site'} = shift;
}
else { croak "$class->new() expects a single URL argument" }
}
return $self;
}
sub site
{
my $self = shift;
$self->{'site'} = shift if(#_);
return $self->{'site'};
}
sub print_method
{
my $self = shift;
print $self->site, "\n";
}
1;
Example usage:
use Link;
my $link = Link->new('http://somesite.com');
print $link, "\n"; # http://somesite.com
$link->print_method; # http://somesite.com
If you really, really want assignment to work too, you can combine a normal object with overloaded stringification (Link, above) with tie:
package LinkTie;
use strict;
use Link;
sub FETCH
{
my $this = shift;
return $this->{'link'};
}
sub STORE
{
my($self, $site) = #_;
$self->{'link'}->site($site);
return $site;
}
# XXX: You could generalize this delegation with Class::Delegation or similar
sub print_method
{
my $self = shift;
print $self->{'link'}->print_method;
}
sub TIESCALAR
{
my $class = shift;
my $self = bless {}, $class;
$self->{'link'} = Link->new(#_);
return $self;
}
1;
Example usage:
tie my $link,'LinkTie','http://somesite.com';
print $link, "\n"; # http://somesite.com
$link->print_method; # http://somesite.com
$link = 'http://othersite.com';
print $link, "\n"; # http://othersite.com
$link->print_method; # http://othersite.com
This is all quite hideous and a long way to go just to get the dubious ability to assign to something that you can also call methods on and also print as-is. A standard URI object with stringification is probably a better bet.