#!/usr/bin/perl -w
use strict;

# show how to tie scalars existing init routines the lazy way
$| = 1;


# --------------------------------------------------
package LegacyRoutines;

use vars qw($AUTOLOAD);

sub foo {
    print __PACKAGE__ . "::foo magically called\n";
    return 42;
}

sub baz {
    print __PACKAGE__ . "::baz magically called\n";
    return "hooray";
}

# no bar routine here - catch errors
sub AUTOLOAD {
    "LegacyRoutines: undefined subroutine $AUTOLOAD called\n";
}


# --------------------------------------------------
package MyGlobals;

# global to map objects to associated init routine names
my %mappings; 

# global to memorize package globals to initialize
my %vars;


sub TIESCALAR { 
    my $class = shift;
    my ($name, $var) = @_;
    bless \ (my $self), $class;
    $mappings{\$self} = $name;
    $vars{\$self} = $var;
    return \$self;
}

sub FETCH {
    print __PACKAGE__ ."::FETCH called\n";
    # $_[0] - alias to original object ref we stored in %mappings
    my $value;
    if (not defined ${$_[0]}) {
        print "Initializing $_[0] ... \n";
        # check if we have an entry for that object
        if (not exists $mappings{$_[0]}) {
            print "No matching subroutine for ", $_[0], "\n"; 
            return $_[0];
        }
        # call to init routine associated with $self
        no strict 'refs';
        # set original value
        ${$_[0]} = &{ $mappings{$_[0]} }();
        # remember it
        $value = ${$_[0]};
        # untie package global
        if (exists $vars{$_[0]}) {
            untie ${$vars{$_[0]}};
        }
        return $value;
    }
    return ${$_[0]};
}

sub STORE { 
    # whatever you want
}

sub DESTROY { 
    # whatever you want
}



# --------------------------------------------------
package main;

use vars qw($foo);

tie($foo, "MyGlobals", "LegacyRoutines::foo", "main::foo");
tie(my $bar, "MyGlobals", "LegacyRoutines::bar");
tie(my $baz1, "MyGlobals", "LegacyRoutines::baz");
tie(my $baz2, "MyGlobals", "LegacyRoutines::baz"); 

# make $baz2 a de-facto alias to $baz1

print $foo, "\n";
print $foo, "\n";

print $bar, "\n"; 

print $baz1, "\n";
print $baz1, "\n";

print $baz2, "\n";
print $baz2, "\n";