I choose to use tie and find this:
package Galaxy::IO::INI;
sub new {
my $invocant = shift;
my $class = ref($invocant) || $invocant;
my $self = {']' => []}; # ini section can never be ']'
tie %{$self},'INIHash';
return bless $self, $class;
}
package INIHash;
use Carp;
require Tie::Hash;
#INIHash::ISA = qw(Tie::StdHash);
sub STORE {
#$_[0]->{$_[1]} = $_[2];
push #{$_[0]->{']'}},$_[1] unless exists $_[0]->{$_[1]};
for (keys %{$_[2]}) {
next if $_ eq '=';
push #{$_[0]->{$_[1]}->{'='}},$_ unless exists $_[0]->{$_[1]}->{$_};
$_[0]->{$_[1]}->{$_}=$_[2]->{$_};
}
$_[0]->{$_[1]}->{'='};
}
if I remove the last "$[0]->{$[1]}->{'='};", it does not work correctly.
Why ?
I know a return value is required. But "$[0]->{$[1]};" cannot work correctly either, and $[0]->{$[1]}->{'='} is not the whole thing.
Old post:
I am write a package in Perl for parsing INI files.
Just something based on Config::Tiny.
I want to keep the order of sections & keys, so I use extra array to store the order.
But when I use " $Config->{newsection} = { this => 'that' }; # Add a section ", I need to overload '=' so that "newsection" and "this" can be pushed in the array.
Is this possible to make "$Config->{newsection} = { this => 'that' };" work without influence other parts ?
Part of the code is:
sub new {
my $invocant = shift;
my $class = ref($invocant) || $invocant;
my $self = {']' => []}; # ini section can never be ']'
return bless $self, $class;
}
sub read_string {
if ( /^\s*\[\s*(.+?)\s*\]\s*$/ ) {
$self->{$ns = $1} ||= {'=' => []}; # ini key can never be '='
push #{$$self{']'}},$ns;
next;
}
if ( /^\s*([^=]+?)\s*=\s*(.*?)\s*$/ ) {
push #{$$self{$ns}{'='}},$1 unless defined $$self{$ns}{$1};
$self->{$ns}->{$1} = $2;
next;
}
}
sub write_string {
my $self = shift;
my $contents = '';
foreach my $section (#{$$self{']'}}) {
}}
Special Symbols for Overload
lists the behaviour of Perl overloading for '='.
The value for "=" is a reference to a function with three arguments, i.e., it looks like the other values in use overload. However, it does not overload the Perl assignment operator. This would go against Camel hair.
So you will probably need to rethink your approach.
This is not exactly JUST operator overloading, but if you absolutely need this functionality, you can try a perl tie:
http://perldoc.perl.org/functions/tie.html
Do you know about Config::IniFiles? You might consider that before you go off and reinvent it. With some proper subclassing, you can add ordering to it.
Also, I think you have the wrong interface. You're exposing the internal structure of your object and modifying it through magical assignments. Using methods would make your life much easier.
Related
How can I hide a "tie" call from the user so calling an accessor will implicitly do it for them?
I want to do this, because I have a data structure that can be accessed by the user, but values stored in this structure can be modified without the user's knowledge.
If an attribute in the data structure changes, I want any variables referencing that attribute modified as well so the user will always be using fresh data. Since the user will always want fresh data, it's simpler and more intuitive if the user doesn't even need to know it's happening.
This is what I have so far... it doesn't seem to work though, the output is:
hello
hello
What I want is:
hello
goodbye
Code:
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
{
package File;
use Moose;
has '_text' => (is => 'rw', isa => 'Str', required => 1);
sub text {
my ($self) = #_;
tie my $text, 'FileText', $self;
return $text;
}
}
{
package FileText;
use Tie::Scalar;
sub TIESCALAR {
my ($class, $obj) = #_;
return bless \$obj, $class;
}
sub FETCH {
my ($self) = #_;
return $$self->_text();
}
sub STORE {
die "READ ONLY";
}
}
my $file = 'File'->new('_text' => 'hello');
my $text = $file->text();
say $text;
$file->_text('goodbye');
say $text;
I would not recommend doing this. You're introducing "action at a distance" which leads to some very difficult to catch bugs. The user thinks they're getting a string. A lexical string can only be altered by changing it directly and obviously. It has to be altered in place or obviously passed into a function or a reference attached to something.
my $text = $file->text;
say $text; # let's say it's 'foo'
...do some stuff...
$file->text('bar');
...do some more stuff...
# I should be able to safely assume it will still be 'foo'
say $text;
That block of code is easy to understand because all the things which could affect $text are immediately visible. This is what lexical context is all about, isolating what can change a variable.
By returning a thing which can change at any time, you've quietly broken this assumption. There's no indication to the user that assumption has been broken. When they go to print $text and get bar it is non-obvious what changed $text. Anything in the whole program could change $text. That small block of code is now infinitely more complicated.
Another way to look at it is this: scalar variables in Perl have a defined interface. Part of that interface says how they can be changed. You are breaking this interface and lying to the user. This is how overloaded/tied variables are typically abused.
Whatever problem you're trying to solve, you're solving it by adding more problems, by making the code more complex and difficult to understand. I would step back and ask what problem you're trying to solve with tying.
What I would do instead is to just return a scalar reference. This alerts the user that it can be changed out from under them at any time. No magic to cover up a very important piece of information.
#!/usr/bin/perl
use warnings;
use strict;
use feature qw{ say };
{
package File;
use Moose;
has 'text_ref' => (
is => 'rw',
isa => 'Ref',
default => sub {
return \("");
}
);
sub BUILDARGS {
my $class = shift;
my %args = #_;
# "Cast" a scalar to a scalar ref.
if( defined $args{text} ) {
$args{text_ref} = \(delete $args{text});
}
return \%args;
}
sub text {
my $self = shift;
if( #_ ) {
# Change the existing text object.
${$self->text_ref} = shift;
return;
}
else {
return $self->text_ref;
}
}
}
my $file = 'File'->new('text' => 'hello');
my $text = $file->text();
say $$text;
$file->text('goodbye');
say $$text;
That said, here's how you do what you want.
I would recommend against using tie. It is very slow, considerably slower than a method call, buggy and quirky. One of its quirks is that the tied nature is attached to the variable itself, not the referenced data. That means you can't return a tied variable.
Instead, I would recommend using an overloaded object to store your changing text.
{
package ChangingText;
# Moose wants class types to be in a .pm file. We have to explciitly
# tell it this is a class type.
use Moose::Util::TypeConstraints qw(class_type);
class_type('ChangingText');
use overload
'""' => sub {
my $self = shift;
return $$self;
},
fallback => 1;
sub new {
my $class = shift;
my $text = shift;
return bless \$text, $class;
}
sub set_text {
my $self = shift;
my $new_text = shift;
$$self = $new_text;
return;
}
}
Overloaded objects have their own caveats, mostly due to code which expects strings writing things like if !ref $arg, but they are easier to deal with than the deep tie bugs.
To make this transparent, store the ChangingText object in the File object and then put a hand made text accessor around it to handle plain strings. The accessor makes sure to reuse the same ChangingText object.
To complete the illusion, BUILDARGS is used to change plain text initialization arguments into a ChangingText object.
{
package File;
use Moose;
has 'text_obj' => (
is => 'rw',
isa => 'ChangingText',
default => sub {
return ChangingText->new;
}
);
sub BUILDARGS {
my $class = shift;
my %args = #_;
# "Cast" plain text into a text object
if( defined $args{text} ) {
$args{text_obj} = ChangingText->new(delete $args{text});
}
return \%args;
}
sub text {
my $self = shift;
if( #_ ) {
# Change the existing text object.
$self->text_obj->set_text(shift);
return;
}
else {
return $self->text_obj;
}
}
}
Then it works transparently.
my $file = File->new('text' => 'hello');
my $text = $file->text();
say $text; # hello
$file->text('goodbye');
say $text; # goodbye
return $text just returns the value of the variable, not the variable itself. You can return a reference to it, though:
sub text {
my ($self) = #_;
tie my $text, 'FileText', $self;
return \$text;
}
You then have to use $$text to dereference it:
my $file = 'File'->new('_text' => 'hello');
my $text = $file->text();
say $$text;
$file->_text('goodbye');
say $$text;
If perlcritic says "having no returns in a sub is wrong", what is the alternative if they really aren't needed?
I've developed two apparently bad habits:
I explicitly assign variables to the '$main::' namespace.
I then play with those variables in subs.
For example, I might do..
#!/usr/bin/perl
use strict;
use warnings;
#main::array = (1,4,2,6,1,8,5,5,2);
&sort_array;
&push_array;
&pop_array;
sub sort_array{
#main::array = sort #main::array;
for (#main::array){
print "$_\n";
}
}
sub push_array{
for ( 1 .. 9 ){
push #main::array, $_;
}
}
sub pop_array {
for ( 1 .. 3 ){
pop #main::array;
}
}
I don't do this all the time. But in the above, it makes sense, because I can segregate the operations, not have to worry about passing values back and forth and it generally looks tidy to me.
But as I said, perl critic says its wrong - because there's no return..
So, is anyone able to interpret what I'm trying to do and suggest a better way of approaching this style of coding in perl? eg. am I sort of doing OOP?
In short - yes, you're basically doing OO, but in a way that's going to confuse everyone.
The danger of doing subs like that is that you're acting at a distance. It's a bad coding style to have to look somewhere else entirely for what might be breaking your code.
This is generally why 'globals' are to be avoided wherever possible.
For a short script, it doesn't matter too much.
Regarding return values - Perl returns the result of the last expression by default. (See: return)
(In the absence of an explicit return, a subroutine, eval, or do FILE automatically returns the value of the last expression evaluated.)
The reason Perl critic flags it is:
Require all subroutines to terminate explicitly with one of the following: return, carp, croak, die, exec, exit, goto, or throw.
Subroutines without explicit return statements at their ends can be confusing. It can be challenging to deduce what the return value will be.
Furthermore, if the programmer did not mean for there to be a significant return value, and omits a return statement, some of the subroutine's inner data can leak to the outside.
Perlcritic isn't always right though - if there's good reason for doing what you're doing, then turn it off. Just as long as you've thought about it and are aware of the risks an consequences.
Personally I think it's better style to explicitly return something, even if it is just return;.
Anyway, redrafting your code in a (crude) OO fashion:
#!/usr/bin/perl
use strict;
use warnings;
package MyArray;
my $default_array = [ 1,4,2,6,1,8,5,5,2 ];
sub new {
my ( $class ) = #_;
my $self = {};
$self -> {myarray} = $default_array;
bless ( $self, $class );
return $self;
}
sub get_array {
my ( $self ) = #_;
return ( $self -> {myarray} );
}
sub sort_array{
my ( $self ) = #_;
#{ $self -> {myarray} } = sort ( #{ $self -> {myarray} } );
for ( #{ $self -> {myarray} } ) {
print $_,"\n";
}
return 1;
}
sub push_array{
my ( $self ) = #_;
for ( 1 .. 9 ){
push #{$self -> {myarray}}, $_;
}
return 1;
}
sub pop_array {
my ( $self ) = #_;
for ( 1 .. 3 ){
pop #{$self -> {myarray}};
}
return 1;
}
1;
And then call it with:
#!/usr/bin/perl
use strict;
use warnings;
use MyArray;
my $array = MyArray -> new();
print "Started:\n";
print join (",", #{ $array -> get_array()} ),"\n";
print "Reshuffling:\n";
$array -> sort_array();
$array -> push_array();
$array -> pop_array();
print "Finished:\n";
print join (",", #{ $array -> get_array()} ),"\n";
It can probably be tidied up a bit, but hopefully this illustrates - within your object, you've got an internal 'array' which you then 'do stuff with' by making your calls.
Result is much the same (I think I've replicated the logic, but don't trust that entirely!) but you have a self contained thing going on.
If the function doesn't mean to return anything, there's no need to use return!
No, you don't use any aspects of OO (encapsulation, polymorphism, etc). What you are doing is called procedural programming. Nothing wrong with that. All my work for nuclear power plants was written in that style.
The problem is using #main::array, and I'm not talking about the fact that you could abbreviate that to #::array. Fully-qualified names escape strict checks, so they are far, far more error-prone. Mistyped var name won't get caught as easily, and it's easy to have two pieces of code collide by using the same variable name.
If you're just using one file, you can use my #array, but I presume you are using #main::array because you are accessing it from multiple files/modules. I suggest placing our #array in a module, and exporting it.
package MyData;
use Exporter qw( import );
our #EXPORT = qw( #array );
our #array;
1;
Having some kind of hint in the variable name (such as a prefix or suffix) indicating this is a variable used across many modules would be nice.
By the way, if you wanted do create an object, it would look like
package MyArray;
sub new {
my $class = shift;
my $self = bless({}, $class);
$self->{array} = [ #_ ];
return $self;
}
sub get_elements {
my ($self) = #_;
return #{ $self->{array} };
}
sub sort {
my ($self) = #_;
#{ $self->{array} } = sort #{ $self->{array} };
}
sub push {
my $self = shift;
push #{ $self->{array} }, #_;
}
sub pop {
my ($self, $n) = #_;
return splice(#{ $self->{array} }, 0, $n//1);
}
my $array = MyArray->new(1,4,2,6,1,8,5,5,2);
$array->sort;
print("$_\n") for $array->get_elements();
$array->push_array(1..9);
$array->pop_array(3);
I improved your interface a bit. (Sorting shouldn't print. Would be nice to push different things and to pop other than three elements.)
I need to transform data structures from a list of arrays into a tree-like one. I know the depth of the tree before I start processing the data, but I want to keep things flexible so I can re-use the code.
So I landed upon the idea of generating a subref on the fly (from within a Moose-based module) to go from array to tree. Like this (in a simplified way):
use Data::Dump qw/dump/;
sub create_tree_builder {
my $depth = shift;
return eval join '', 'sub { $_[0]->{$_[',
join(']}->{$_[', (1..$depth)),
']} = $_[', $depth + 1 , '] }';
}
my $s = create_tree_builder(5);
my $tree = {};
$s->($tree, qw/one two three four five/, 'a value');
print dump $tree;
# prints
# {
# one => { two => { three => { four => { five => "a value" } } } },
# }
This opened up worlds to me, and I'm finding cool uses for this process of eval-in a parametrically generated string into a function all over the place (clearly, a solution in search of problems).
However, it feels a little too good to be true, almost.
Any advice against this practice? Or suggestion for improvements?
I can see clearly that eval-ing arbitrary input might not be the safest thing, but what else?
Follow up
Thanks for all the answers. I used amon's code and benchmarked a bit, like this:
use Benchmark qw(:all) ;
$\ = "\n";
sub create_tree_builder {
my $depth = shift;
return eval join '', 'sub { $_[0]->{$_[',
join(']}->{$_[', (1..$depth)),
']} = $_[', $depth + 1 , '] }';
}
my $s = create_tree_builder(5);
$t = sub {
$_[0] //= {};
my ($tree, #keys) = #_;
my $value = pop #keys;
$tree = $tree->{shift #keys} //= {} while #keys > 1;
$tree->{$keys[0]} = $value;
};
cmpthese(900000, {
'eval' => sub { $s->($tree, qw/one two three four five/, 'a value') },
'build' => sub { $t->($tree, qw/one two three four five/, 'a value') },
});
The results are clearly in favour of building the tree, not of the eval'ed factory:
Rate build eval
build 326087/s -- -79%
eval 1525424/s 368% --
I'll admit I could have done that before. I'll try with more random trees (rather than assigning the same element over and over) but I see no reason that the results should be different.
Thanks a lot for the help.
It is very easy to write a generalized subroutine to build such a nested hash. It is much simpler that way than writing a factory that will produce such a subroutine for a specific number of hash levels.
use strict;
use warnings;
sub tree_assign {
# Create an empty tree if one was not given, using an alias to the original argument
$_[0] //= {};
my ($tree, #keys) = #_;
my $value = pop #keys;
$tree = $tree->{shift #keys} //= {} while #keys > 1;
$tree->{$keys[0]} = $value;
}
tree_assign(my $tree, qw/one two three four five/, 'a value');
use Data::Dump;
dd $tree;
output
{
one => { two => { three => { four => { five => "a value" } } } },
}
Why this might be a bad idea
Maintainability.
Code that is eval'd has to be eval'd inside the programmers head first– not always an easy task. Essentially, evaling is obfuscation.
Speed.
eval re-runs the perl parser and compiler, before normal execution resumes. However, the same technique can be used to gain start-up time by deferring compilation of subroutines until they are needed. This is not such a case.
There is more than one way to do it.
I like anonymous subroutines, but you don't have to use an eval to construct them. They are closures anyway. Something like
...;
return sub {
my ($tree, $keys, $value) = #_;
$#$keys >= $depth or die "need moar keys";
$tree = $tree->{$keys->[$_]} for 0 .. $depth - 1;
$tree->{$keys->[$depth]} = $value;
};
and
$s->($tree, [qw(one two three four five)], "a value");
would do something suprisingly similar. (Actually, using $depth now looks like a design error; the complete path is already specified by the keys. Therefore, creating a normal, named subroutine would probably be best.)
Understanding what the OP is doing a little better based on their comments, and riffing on Borodin's code, I'd suggest an interface change. Rather than writing a subroutine to apply a value deep in a tree, I'd write a subroutine to create an empty subtree and then work on that subtree. This allows you to work efficiently on the subtree without having to walk the tree on every operation.
package Root;
use Mouse;
has root =>
is => 'ro',
isa => 'HashRef',
default => sub { {} };
sub init_subtree {
my $self = shift;
my $tree = $self->root;
for my $key (#_) {
$tree = $tree->{$key} //= {};
}
return $tree;
}
my $root = Root->new;
my $subtree = $root->init_subtree(qw/one two three four/);
# Now you can quickly work with the subtree without having
# to walk down every time. This loop's performance is only
# dependent on the number of keys you're adding, rather than
# the number of keys TIMES the depth of the subtree.
my $val = 0;
for my $key ("a".."c") {
$subtree->{$key} = $val++;
}
use Data::Dump;
dd $root;
Data::Diver is your friend:
use Data::Diver 'DiveVal', 'DiveRef';
my $tree = {};
DiveVal( $tree, qw/one two three four five/ ) = 'a value';
# or if you hate lvalue subroutines:
${ DiveRef( $tree, qw/one two three four five/ ) } = 'a value';
use Data::Dump 'dump';
print dump $tree;
Using sub prototypes, we can define our own subs that look like map or grep. That is, the first coderef argument has shorter syntax than a normal anonymous sub. For example:
sub thunked (&) { $_[0] }
my $val = thunked { 2 * 4 };
Works great here, since the first argument is the coderef. For latter arguments however, it simple won't parse properly.
I made a with sub designed to make writing GTK2 code cleaner. It's meant to look like this (untested since it's hypothetical code):
use 5.012;
use warnings;
use Gtk2 '-init';
sub with ($&) {
local $_ = $_[0];
$_[1]->();
$_;
}
for (Gtk2::Window->new('toplevel')) {
$_->set_title('Test Application');
$_->add(with Gtk2::VBox->new {
my $box = $_;
$box->add(Gtk2::Button->new("Button $_")) for (1..4);
});
$_->show_all;
}
Gtk2->main;
It doesn't work because with needs to take the block as a first argument for the nice syntax to work. Is there any way to pull it off?
The module Devel::Declare contains tools for extending Perl's syntax in a relatively safe way.
Using Devel::Declare you would create a hook on the with token, which will stop the parser when it reaches that word. From there, you have control over the parser and you can read ahead until you reach a { symbol. At that point, you have what you need to work with, so you rewrite it into valid Perl, and pass it back to the parser.
in the file With.pm:
package With;
use warnings;
use strict;
use Devel::Declare;
sub import {
my $caller = caller;
Devel::Declare->setup_for (
$caller => {with => {const => \&parser}}
);
no strict 'refs';
*{$caller.'::with'} = sub ($&) {
$_[1]() for $_[0];
$_[0]
}
}
our $prefix = '';
sub get {substr Devel::Declare::get_linestr, length $prefix}
sub set { Devel::Declare::set_linestr $prefix . $_[0]}
sub parser {
local $prefix = substr get, 0, length($_[0]) + $_[1];
my $with = strip_with();
strip_space();
set "scalar($with), sub " . get;
}
sub strip_space {
my $skip = Devel::Declare::toke_skipspace length $prefix;
set substr get, $skip;
}
sub strip_with {
strip_space;
my $with;
until (get =~ /^\{/) {
(my $line = get) =~ s/^([^{]+)//;
$with .= $1;
set $line;
strip_space;
}
$with =~ s/\s+/ /g;
$with
}
and to use it:
use With;
sub Window::add {say "window add: ", $_[1]->str}
sub Window::new {bless [] => 'Window'}
sub Box::new {bless [] => 'Box'}
sub Box::add {push #{$_[0]}, #_[1..$#_]}
sub Box::str {"Box(#{$_[0]})"}
sub Button::new {"Button($_[1])"}
with Window->new {
$_->add(with Box->new {
for my $num (1 .. 4) {
$_->add(Button->new($num))
}
})
};
Which prints:
window add: Box(Button(1) Button(2) Button(3) Button(4))
A completely different approach would be to skip the with keyword altogether and write a routine to generate constructor subroutines:
BEGIN {
for my $name (qw(VBox)) { # and any others you want
no strict 'refs';
*$name = sub (&#) {
use strict;
my $code = shift;
my $with = "Gtk2::$name"->new(#_);
$code->() for $with;
$with
}
}
}
and then your code could look like
for (Gtk2::Window->new('toplevel')) {
$_->set_title('Test Application');
$_->add(VBox {
my $box = $_;
$box->add(Gtk2::Button->new("Button $_")) for (1..4);
});
$_->show_all;
}
One way that you could deal with it is to add a fairly useless keyword:
sub perform(&) { $_[0] }
with GTK2::VBox->new, perform { ... }
where perform is really just a sugarier alternative to sub.
Another way is to write a Devel::Declare filter or a Syntax::Keyword:: plugin to implement your with, as long as you have some way to tell when you're done parsing the with argument and ready to start parsing the block — balanced parentheses would do (so would an opening curly brace, but then hashes become a problem). Then you could support something like
with (GTK2::VBox->new) { ... }
and let the filter rewrite it to something like
do {
local $_ = GTK2::VBox->new;
do {
...;
};
$_;
}
which, if it works, has the advantage of not actually creating a sub, and thus not interfering with #_, return, and a few other things. The two layers of do-age I think are necessary for being able to install an EndOfScope hook in the proper place.
The obvious disadvantages of this are that it's tricky, it's hairy, and it's a source filter (even if it's a tame one) which means there are problems you have to solve if you want any code using it to be debuggable at all.
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.