view release on metacpan or  search on metacpan

Locations.pm  view on Meta::CPAN

@EXPORT_OK = ();

%EXPORT_TAGS = (all => [@EXPORT_OK]);

$VERSION = "5.5";

bootstrap Data::Locations $VERSION;

my $Class = __PACKAGE__;    ##  This class's name
my $Table = $Class . '::';  ##  This class's symbol table

my $Count = 0;  ##  Counter for generating unique names for all locations
my $Alive = 1;  ##  Flag for disabling auto-dump during global destruction

  *print  = \&PRINT;        ##  Define public aliases for internal methods
  *printf = \&PRINTF;
  *read   = \&READLINE;

sub _usage_
{
    my($text) = @_;

    Carp::croak("Usage: $text");
}

sub _error_
{
    my($name,$text) = @_;

    Carp::croak("${Table}${name}(): $text");
}

sub _alert_
{
    my($name,$text) = @_;

    Carp::carp("${Table}${name}(): $text") if $^W;
}

sub _check_filename_
{
    my($name,$file) = @_;

    if (defined $file)
    {
        if (ref($file))
        {
            &_error_($name, "reference not allowed as filename");
        }
        else
        {
            if ($file !~ /^\s*$/) { return "$file"; }
        }
    }
    return '';
}

sub new
{
  &_usage_("\$[top|sub]location = [$Class|\$location]->new( [ \$filename ] );")
    if ((@_ < 1) || (@_ > 2));

    my($outer) = shift;
    my($file,$name,$inner);

    $file = '';
    $file = shift if (@_ > 0);
    $file = &_check_filename_('new', $file);

    $name = 'LOCATION' . $Count++;   ##  Generate a unique name
no strict "refs";
    $inner = \*{$Table . $name};     ##  Create a reference of glob value
use strict "refs";
    bless($inner, $Class);           ##  Bless glob to become an object
    tie(*{$inner}, $Class, $inner);  ##  Tie glob to itself
    ${*{$inner}} = $inner;           ##  Use $ slot of glob for self-ref
    @{*{$inner}} = ();               ##  Use @ slot of glob for the data
    %{*{$inner}} = ();               ##  Use % slot of glob for obj attributes

    ${*{$inner}}{'name'} = $name;    ##  Also keep symbolic self-ref
    ${*{$inner}}{'file'} = $file;    ##  Store filename (is auto-dump flag)

    ${*{$inner}}{'outer'} = {};      ##  List of surrounding locations
    ${*{$inner}}{'inner'} = {};      ##  List of embedded locations

    ##  Enable destruction when last user ref goes out of scope:

    ${*{$inner}}{'refs'} = &_mortalize_($inner);

    if (ref($outer))  ##  Object method (or else class method)
    {
        ${${*{$inner}}{'outer'}}{${*{$outer}}{'name'}} = 1;
        ${${*{$outer}}{'inner'}}{${*{$inner}}{'name'}} = 1;
        push(@{*{$outer}}, $inner);
    }
    return $inner;
}

sub TIEHANDLE
{
    return $_[1];
}

sub CLOSE
{
    &_alert_("close", "operation ignored");
}

sub _unlink_outer_
{
    my($inner) = @_;
    my($name,$list,$item);

    $name = ${*{$inner}}{'name'};
    $list = ${*{$inner}}{'outer'};
    foreach $item (keys %{$list})
    {
        if (exists $Data::Locations::{$item})
        {
            delete ${${*{ $Data::Locations::{$item} }}{'inner'}}{$name};