File Coverage

blib/lib/Data/Locations.pm

Criterion	Covered	Total	%
statement	333	348	95.6
branch	70	98	71.4
condition	16	45	35.5
subroutine	32	34	94.1
pod	0	9	0.0
total	451	534	84.4

###############################################################################
##                                                                           ##
##    Copyright (c) 1997 - 2009 by Steffen Beyer.                            ##
##    All rights reserved.                                                   ##
##                                                                           ##
##    This package is free software; you can redistribute it                 ##
##    and/or modify it under the same terms as Perl itself.                  ##
##                                                                           ##
###############################################################################

package Data::Locations;

use 5.004;
use strict;
use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION);

require Carp;
require Symbol;
require Exporter;
require DynaLoader;

@ISA = qw(Exporter DynaLoader);

@EXPORT = ();

@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};
        }
    }
    ${*{$inner}}{'outer'} = {};
}

sub _unlink_inner_
{
    my($outer) = @_;
    my($name,$list,$item);

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

sub delete
{
    &_usage_('$location->delete();')
      if ((@_ != 1) || !ref($_[0]));

    my($location) = @_;

    &_unlink_inner_($location);
    delete ${*{$location}}{'stack'};
    @{*{$location}} = ();
}

sub DESTROY
{
    my($location) = @_;

    if ($Alive)
    {
        if (${*{$location}}{'file'} ne '')
        {
            &dump($location);
        }
        &_unlink_outer_($location);
        &_unlink_inner_($location);
        &_resurrect_($location, ${*{$location}}{'refs'});
        delete $Data::Locations::{ ${*{$location}}{'name'} };
        { local($^W) = 0; untie(*{$location}); }
        undef ${*{$location}};
        undef %{*{$location}};
        undef @{*{$location}};
    }
}

sub END
{
    my($item,$location);

    ##  Disable auto-dump during global destruction and dump all relevant
    ##  locations here while all their embedded sublocations still exist
    ##  (because global destruction destroys in random order!):

    $Alive = 0;

    foreach $item (keys %Data::Locations::)
    {
        if ($item =~ /^LOCATION\d+$/)
        {
            $location = ${*{ $Data::Locations::{$item} }};
            if (${*{$location}}{'file'} ne '')
            {
                &dump($location);
            }
            &_resurrect_($location, ${*{$location}}{'refs'});
        }
    }
}

sub filename
{
    &_usage_('$filename = $location->filename( [ $filename ] );')
      if ((@_ < 1) || (@_ > 2) || !ref($_[0]));

    my($location) = shift;
    my($file);

    $file = ${*{$location}}{'file'};
    if (@_ > 0)
    {
        ${*{$location}}{'file'} = &_check_filename_('filename', $_[0]);
    }
    return $file;
}

sub toplevel
{
    &_usage_('$flag = $location->toplevel();')
      if ((@_ != 1) || !ref($_[0]));

    return ! keys(%{${*{$_[0]}}{'outer'}});
}

sub _self_contained_
{
    my($outer,$inner) = @_;
    my($list,$item);

    return 1 if ($outer == $inner);
    $list = ${*{$outer}}{'outer'};
    foreach $item (keys %{$list})
    {
        if (exists $Data::Locations::{$item})
        {
            $outer = ${*{ $Data::Locations::{$item} }};
            return 1 if (&_self_contained_($outer,$inner));
        }
    }
    return 0;
}

sub PRINT  ##  Aliased to "print"
{
    &_usage_('$location->print(@items);')
      if ((@_ < 1) || !ref($_[0]));

    my($outer) = shift;
    my($inner);

    ITEM:
    foreach $inner (@_)
    {
        if (ref($inner))
        {
            if (ref($inner) ne $Class)
            {
                &_alert_("print", ref($inner) . " reference ignored");
                next ITEM;
            }
            if (&_self_contained_($outer,$inner))
            {
                &_error_("print", "infinite recursion loop attempted");
            }
            else
            {
                ${${*{$inner}}{'outer'}}{${*{$outer}}{'name'}} = 1;
                ${${*{$outer}}{'inner'}}{${*{$inner}}{'name'}} = 1;
            }
        }
        push(@{*{$outer}}, $inner);
    }
}

sub PRINTF  ##  Aliased to "printf"
{
    &_usage_('$location->printf($format, @items);')
      if ((@_ < 2) || !ref($_[0]));

    my($location) = shift;
    my($format) = shift;

    &print( $location, sprintf($format, @_) );
}

sub println
{
    &_usage_('$location->println(@items);')
      if ((@_ < 1) || !ref($_[0]));

    my($location) = shift;

    &print( $location, @_, "\n" );

    ##  We use a separate "\n" here (instead of concatenating it
    ##  with the last item) in case the last item is a reference!
}

sub _read_item_
{
    my($location) = @_;
    my($stack,$first,$index,$which,$item);

    if (exists ${*{$location}}{'stack'})
    {
        $stack = ${*{$location}}{'stack'};
    }
    else
    {
        $stack = [ [ 0, ${*{$location}}{'name'} ] ];
        ${*{$location}}{'stack'} = $stack;
    }

    if (@{$stack})
    {
        $first = ${$stack}[0];
        $index = ${$first}[0];
        $which = ${$first}[1];
        if ((exists $Data::Locations::{$which}) &&
            ($index < @{*{ $Data::Locations::{$which} }}))
        {
            $item = ${*{ $Data::Locations::{$which} }}[$index];
            ${$first}[0]++;
            if (defined $item)
            {
                if (ref($item))
                {
                    if (ref($item) eq $Class)
                    {
                        unshift(@{$stack}, [ 0, ${*{$item}}{'name'} ]);
                    }
                    return &_read_item_($location);
                }
                else { return $item; }
            }
            else { return ""; }
        }
        else
        {
            shift(@{$stack});
            return &_read_item_($location);
        }
    }
    else { return undef; }
}

sub _read_list_
{
    my($location) = @_;
    my(@result);
    my($item);

    while (defined ($item = &_read_item_($location)))
    {
        push(@result, $item);
    }
    return( @result );
}

sub READLINE  ##  Aliased to "read"
{
    &_usage_('[ $item | @list ] = $location->read();')
      if ((@_ != 1) || !ref($_[0]));

    my($location) = @_;

    if (defined wantarray)
    {
        if (wantarray)
        {
            return( &_read_list_($location) );
        }
        else
        {
            return &_read_item_($location);
        }
    }
}

sub reset
{
    &_usage_('$location->reset();')
      if ((@_ != 1) || !ref($_[0]));

    delete ${*{$_[0]}}{'stack'};
}

sub _traverse_recursive_
{
    my($location,$callback) = @_;
    my($item);

    foreach $item (@{*{$location}})
    {
        if (ref($item))
        {
            if (ref($item) eq $Class)
            {
                &_traverse_recursive_($item,$callback);
            }
        }
        else
        {
            &{$callback}($item);
        }
    }
}

sub traverse
{
    &_usage_('$location->traverse(\&callback_function);')
      if ((@_ != 2) || !ref($_[0]));

    my($location,$callback) = @_;

    if (ref($callback) ne 'CODE')
    {
        &_error_("traverse", "not a code reference");
    }
    &_traverse_recursive_($location,$callback);
}

sub _dump_recursive_
{
    my($location,$filehandle) = @_;
    my($item);

    foreach $item (@{*{$location}})
    {
        if (ref($item))
        {
            if (ref($item) eq $Class)
            {
                &_dump_recursive_($item,$filehandle);
            }
        }
        else
        {
            print $filehandle $item;
        }
    }
}

sub dump
{
    &_usage_('$ok = $location->dump( [ $filename ] );')
      if ((@_ < 1) || (@_ > 2) || !ref($_[0]));

    my($location) = shift;
    my($file);

    local(*FILEHANDLE);

    $file = ${*{$location}}{'file'};
    $file = shift if (@_ > 0);
    $file = &_check_filename_('dump', $file);

    if ($file =~ /^\s*$/)
    {
        &_alert_("dump", "filename missing or empty");
        return 0;
    }
    unless ($file =~ /^\s*[>\|+]/)
    {
        $file = '>' . $file;
    }
    unless (open(FILEHANDLE, $file))
    {
        &_alert_("dump", "can't open file '$file': \L$!\E");
        return 0;
    }
    &_dump_recursive_($location,*FILEHANDLE);
    unless (close(FILEHANDLE))
    {
        &_alert_("dump", "can't close file '$file': \L$!\E");
        return 0;
    }
    return 1;
}

sub tie
{
    &_usage_('$location->tie( [ "FH" | *FH | \*FH | *{FH} | \*{FH} | $fh ] );')
      if ((@_ != 2) || !ref($_[0]));

    my($location,$filehandle) = @_;

    $filehandle =~ s/^\*//;
    $filehandle = Symbol::qualify($filehandle, caller);
no strict "refs";
    tie(*{$filehandle}, $Class, $location);
use strict "refs";
}

1;

__END__