File Coverage

blib/lib/String/Divert.pm

Criterion	Covered	Total	%
statement	221	307	71.9
branch	66	148	44.5
condition	21	45	46.6
subroutine	31	40	77.5
pod	19	19	100.0
total	358	559	64.0

##
##  String::Divert - String Object supporting Folding and Diversion
##  Copyright (c) 2003-2005 Ralf S. Engelschall
##
##  This file is part of String::Divert, a Perl module providing
##  a string object supporting folding and diversion.
##
##  This program is free software; you can redistribute it and/or
##  modify it under the terms of the GNU General Public  License
##  as published by the Free Software Foundation; either version
##  2.0 of the License, or (at your option) any later version.
##
##  This program is distributed in the hope that it will be useful,
##  but WITHOUT ANY WARRANTY; without even the implied warranty of
##  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
##  General Public License for more details.
##
##  You should have received a copy of the GNU General Public License
##  along with this file; if not, write to the Free Software Foundation,
##  Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA.
##
##  Divert.pm: Module Implementation
##

#   _________________________________________________________________________
#
#   STANDARD OBJECT ORIENTED API
#   _________________________________________________________________________
#

package String::Divert;

use 5.006;
use strict;
use warnings;

use Carp;
require Exporter;

our $VERSION   = '0.96';

our @ISA       = qw(Exporter);
our @EXPORT    = qw();
our @EXPORT_OK = qw();

#   internal: create an anonymous object name
my $_anonymous_count = 1;
sub _anonymous_name () {
    return sprintf("ANONYMOUS:%d", $_anonymous_count++);
}

#   object construction
sub new ($;$) {
    my ($proto, $name) = @_;

    my $class = ref($proto) || $proto;
    my $self = {};
    bless ($self, $class);

    $name ||= &String::Divert::_anonymous_name();

    $self->{name}      = $name;                             # name of object
    $self->{overwrite} = 'none';                            # overwrite mode (none|once|always)
    $self->{storage}   = 'all';                             # storage mode (none|fold|all)
    $self->{copying}   = 'pass';                            # copying mode (pass|clone)
    $self->{chunks}    = [];                                # string chunks
    $self->{diversion} = [];                                # stack of active diversions
    $self->{foldermk}  = '{#%s#}';                          # folder text representation format
    $self->{folderre}  = '\{#([a-zA-Z_][a-zA-Z0-9_]*)#\}';  # folder text representation regexp
    $self->{folderlst} = undef;                             # folder object of last folding operation

    return $self;
}

#   object destruction (explicit)
sub destroy ($) {
    $_[0]->overload(0);
    bless $_[0], 'UNIVERSAL';
    undef $_[0];
    return;
}

#   object destruction (implicit)
sub DESTROY ($) {
    $_[0]->overload(0);
    bless $_[0], 'UNIVERSAL';
    return;
}

#   clone object
sub clone ($) {
    my ($self) = @_;
    my $ov = $self->overload();
    $self->overload(0);
    eval { require Storable; };
    croak "required module \"Storable\" not installed" if ($@);
    my $clone = Storable::dclone($self);
    $self->overload($ov);
    $clone->overload($ov);
    return $clone;
}

#   operation: set/get name of object
sub name ($;$) {
    my ($self, $name) = @_;
    return $self->{diversion}->[-1]->name($name)
        if (@{$self->{diversion}} > 0);
    my $old_name = $self->{name};
    if (defined($name)) {
        $self->{name} = $name;
    }
    return $old_name;
}

#   operation: set/get overwrite mode
sub overwrite ($;$) {
    my ($self, $mode) = @_;
    return $self->{diversion}->[-1]->overwrite($mode)
        if (@{$self->{diversion}} > 0);
    my $old_mode = $self->{overwrite};
    if (defined($mode)) {
        croak "invalid overwrite mode argument"
            if ($mode !~ m/^(none|once|always)$/);
        $self->{overwrite} = $mode;
    }
    return $old_mode;
}

#   operation: set/get storage mode
sub storage ($;$) {
    my ($self, $mode) = @_;
    return $self->{diversion}->[-1]->storage($mode)
        if (@{$self->{diversion}} > 0);
    my $old_mode = $self->{storage};
    if (defined($mode)) {
        croak "invalid storage mode argument"
            if ($mode !~ m/^(none|fold|all)$/);
        $self->{storage} = $mode;
    }
    return $old_mode;
}

#   operation: set/get copy constructor mode
sub copying ($;$) {
    my ($self, $mode) = @_;
    return $self->{diversion}->[-1]->copying($mode)
        if (@{$self->{diversion}} > 0);
    my $old_mode = $self->{copying};
    if (defined($mode)) {
        croak "invalid copying mode argument"
            if ($mode !~ m/^(clone|pass)$/);
        $self->{copying} = $mode;
    }
    return $old_mode;
}

#   internal: split string into chunks
sub _chunking ($$) {
    my ($self, $string) = @_;
    my @chunks = ();
    my $folderre = $self->{folderre};
    while ($string =~ m/${folderre}()/s) {
        my ($prolog, $id) = ($`, $1);
        push(@chunks, $prolog) if ($prolog ne '' and $self->{storage} !~ m/^(none|fold)/);
        croak "empty folding object name"
            if ($id eq '');
        if ($self->{storage} ne 'none') {
            my $object = $self->folding($id);
            $object = $self->new($id) if (not defined($object));
            croak "cannot create new folding sub object \"$id\""
                if (not defined($object));
            push(@chunks, $object);
        }
        $string = $';
    }
    push(@chunks, $string) if ($string ne '' and $self->{storage} !~ m/^(none|fold)/);
    return @chunks;
}

#   operation: assign an object
sub assign ($$) {
    my ($self, $obj) = @_;
    return $self->{diversion}->[-1]->assign($obj)
        if (@{$self->{diversion}} > 0);
    croak "cannot assign undefined object"
        if (not defined($obj));
    if (&String::Divert::_isobj($obj)) {
        $self->{chunks} = [ $obj ];
        $self->{folderlst} = $obj if (ref($obj));
    }
    else {
        $self->{chunks} = [];
        foreach my $chunk ($self->_chunking($obj)) {
            push(@{$self->{chunks}}, $chunk);
            $self->{folderlst} = $chunk if (ref($chunk));
        }
    }
    return $self;
}

#   operation: append an object
sub append ($$) {
    my ($self, $obj) = @_;
    return $self->{diversion}->[-1]->append($obj)
        if (@{$self->{diversion}} > 0);
    croak "cannot append undefined object"
        if (not defined($obj));
    if (   $self->{overwrite} eq 'once'
        or $self->{overwrite} eq 'always') {
        $self->assign($obj);
        $self->{overwrite} = 'none'
            if ($self->{overwrite} eq 'once');
    }
    else {
        if (&String::Divert::_isobj($obj)) {
            push(@{$self->{chunks}}, $obj);
            $self->{folderlst} = $obj if (ref($obj));
        }
        else {
            foreach my $chunk ($self->_chunking($obj)) {
                if (ref($chunk) or (@{$self->{chunks}} > 0 and ref($self->{chunks}->[-1]))) {
                    push(@{$self->{chunks}}, $chunk);
                    $self->{folderlst} = $chunk if (ref($chunk));
                }
                elsif (@{$self->{chunks}} > 0) {
                    $self->{chunks}->[-1] .= $chunk;
                }
                else {
                    $self->{chunks} = [ $chunk ];
                }
            }
        }
    }
    return $self;
}

#   operation: unfold (and return) string contents temporarily
sub string ($) {
    my ($self) = @_;
    return $self->{diversion}->[-1]->string()
        if (@{$self->{diversion}} > 0);
    return $self->_string([]);
}

#   internal: string() operation with loop detection
sub _string ($$) {
    my ($self, $visit) = @_;
    my $string = '';
    if (grep { &String::Divert::_isobjeq($_, $self) } @{$visit}) {
        croak "folding loop detected: " .
            join(" -> ", map { $_->name() } @{$visit}) .
            " -> " . $self->name();
    }
    push(@{$visit}, $self);
    foreach my $chunk (@{$self->{chunks}}) {
        if (ref($chunk)) {
            #   folding loop detection
            my $prefix = '';
            #   check for existing prefix
            #   (keep in mind that m|([^\n]+)$|s _DOES NOT_
            #   take a possibly existing terminating newline
            #   into account, so we really need an extra match!)
            if ($string =~ m|([^\n]+)$|s and $string !~ m|\n$|s) {
                $prefix = $1;
                $prefix =~ s|[^ \t]| |sg;
            }
            my $block = $chunk->_string($visit); # recursion!
            $block =~ s|\n(?=.)|\n$prefix|sg if ($prefix ne '');
            $string .= $block;
        }
        else {
            $string .= $chunk;
        }
    }
    pop(@{$visit});
    return $string;
}

#   operation: unfold string contents temporarily until already true or finally false
sub bool ($) {
    my ($self) = @_;
    return $self->{diversion}->[-1]->bool()
        if (@{$self->{diversion}} > 0);
    my $string = '';
    foreach my $chunk (@{$self->{chunks}}) {
        if (ref($chunk)) {
            $string .= $chunk->string(); # recursion!
        }
        else {
            $string .= $chunk;
        }
        return 1 if ($string);
    }
    return 0;
}

#   operation: append folding sub-object
sub fold ($;$) {
    my ($self, $id) = @_;
    return $self->{diversion}->[-1]->fold($id)
        if (@{$self->{diversion}} > 0);
    return undef if ($self->{storage} eq 'none');
    $id = &String::Divert::_anonymous_name()
        if (not defined($id));
    if (ref($id)) {
        croak "folding object not of class String::Divert"
            if (not &String::Divert::_isobj($id));
        push(@{$self->{chunks}}, $id);
        $self->{folderlst} = $id;
        return $id;
    }
    else {
        my $object = $self->folding($id);
        $object = $self->new($id) if (not defined($object));
        croak "unable to create new folding object"
            if (not defined($object));
        push(@{$self->{chunks}}, $object);
        $self->{folderlst} = $object;
        return $object;
    }
}

#   operation: unfold string contents permanently
sub unfold ($) {
    my ($self) = @_;
    return $self->{diversion}->[-1]->unfold()
        if (@{$self->{diversion}} > 0);
    my $string = $self->string();
    $self->{chunks} = $string ne '' ? [ $string ] : [];
    $self->{folderlst} = undef;
    return $string;
}

#   internal: check whether object is a String::Divert object
sub _isobj ($) {
    my ($obj) = @_;
    return (    ref($obj)
            and (   UNIVERSAL::isa($obj, "String::Divert")
                 or UNIVERSAL::isa($obj, "String::Divert::__OVERLOAD__")));
}

#   internal: compare whether two objects are the same
sub _isobjeq ($$) {
    my ($obj1, $obj2) = @_;
    my $ov1 = $obj1->overload();
    my $ov2 = $obj2->overload();
    $obj1->overload(0);
    $obj2->overload(0);
    my $rv = ($obj1 == $obj2);
    $obj1->overload($ov1);
    $obj2->overload($ov2);
    return $rv;
}

#   operation: lookup particular or all folding sub-object(s)
sub folding ($;$) {
    my ($self, $id) = @_;
    if (defined($id)) {
        my $folding; $folding = undef;
        foreach my $chunk (@{$self->{chunks}}) {
            if (ref($chunk)) {
                if (   (ref($id)     and &String::Divert::_isobjeq($chunk, $id))
                    or (not ref($id) and $chunk->name() eq $id) ) {
                    $folding = $chunk;
                    last;
                }
                $folding = $chunk->folding($id); # recursion!
                last if (defined($folding));
            }
        }
        return $folding;
    }
    else {
        my @foldings = ();
        foreach my $chunk (@{$self->{chunks}}) {
            if (ref($chunk)) {
                foreach my $subchunk ($chunk->folding()) {
                    push(@foldings, $subchunk);
                }
                push(@foldings, $chunk);
            }
        }
        return @foldings;
    }
}

#   operation: configure or generate textually represented folding object
sub folder ($;$$) {
    my ($self, $a, $b) = @_;
    if (defined($a) and defined($b)) {
        #   configure folder
        my $test = sprintf($a, "foo");
        my ($id) = ($test =~ m|${b}()|s);
        croak "folder construction format and matching regular expression do not correspond"
            if (not defined($id) or (defined($id) and $id ne "foo"));
        $self->{foldermk} = $a;
        $self->{folderre} = $b;
        return;
    }
    else {
        #   create folder
        return "" if ($self->{storage} eq 'none');
        $a = &String::Divert::_anonymous_name()
            if (not defined($a));
        my $folder = sprintf($self->{foldermk}, $a);
        return $folder;
    }
}

#   operation: push diversion of operations to sub-object
sub divert ($;$) {
    my ($self, $id) = @_;
    my $object; $object = undef;
    if (not defined($id)) {
        #   choose last folding object
        foreach my $obj (reverse ($self, @{$self->{diversion}})) {
            $object = $obj->{folderlst};
            last if (defined($object));
        }
        croak "no last folding sub-object found"
            if (not defined($object));
    }
    else {
        #   choose named folding object
        $object = $self->folding($id);
        croak "folding sub-object \"$id\" not found"
            if (not defined($object));
    }
    push(@{$self->{diversion}}, $object);
    return $self;
}

#   operation: pop diversion of operations to sub-object
sub undivert ($;$) {
    my ($self, $num) = @_;
    $num = 1 if (not defined($num));
    if ($num !~ m|^\d+$|) {
        #   lookup number by name
        my $name = $num;
        for (my $num = 1; $num <= @{$self->{diversion}}; $num++) {
            last if ($self->{diversion}->[-$num]->{name} eq $name);
        }
        croak "no object named \"$name\" found for undiversion"
            if ($num > @{$self->{diversion}});
    }
    $num = @{$self->{diversion}} if ($num == 0);
    croak "less number (".scalar(@{$self->{diversion}}).") of " .
        "diversions active than requested ($num) to undivert"
        if ($num > @{$self->{diversion}});
    while ($num-- > 0) {
        pop(@{$self->{diversion}});
    }
    return $self;
}

#   operation: lookup last or all diversion(s)
sub diversion ($) {
    my ($self) = @_;
    if (not wantarray) {
        #   return last diversion only (or undef if none exist)
        return $self->{diversion}->[-1];
    }
    else {
        #   return all diversions (in reverse order of activation) (or empty array if none exist)
        return reverse(@{$self->{diversion}});
    }
}

#   _________________________________________________________________________
#
#   API SWITCHING
#   _________________________________________________________________________
#

#   object overloading toogle method
sub overload ($;$) {
    #   NOTICE: This function is special in that it exploits the fact
    #   that Perl's @_ contains just ALIASES for the arguments of
    #   the function and hence the function can adjust them. This
    #   allows us to tie() the variable of our object ($_[0]) into the
    #   overloading sub class or back to our main class. Just tie()ing
    #   a copy of $_[0] (usually named $self in the other methods)
    #   would be useless, because the Perl TIE mechanism is attached to
    #   _variables_ and not to the objects itself. Hence this function
    #   does no "my ($self, $mode) = @_;" and instead uses @_ directly
    #   throughout its body.
    my $old_mode = (ref($_[0]) eq "String::Divert" ? 0 : 1);
    if (defined($_[1])) {
        if ($_[1]) {
            #   bless and tie into overloaded subclass
            my $self = $_[0];
            bless $_[0], "String::Divert::__OVERLOAD__";
            #tie   $_[0], "String::Divert::__OVERLOAD__", $self;
            #   according to "BUGS" section in "perldoc overload":
            #   "Relation between overloading and tie()ing is broken.
            #   Overloading is triggered or not basing on the previous
            #   class of tie()d value. This happens because the presence
            #   of overloading is checked too early, before any tie()d
            #   access is attempted. If the FETCH()ed class of the
            #   tie()d value does not change, a simple workaround is to
            #   access the value immediately after tie()ing, so that
            #   after this call the previous class coincides with the
            #   current one."... So, do this now!
            #my $dummy = ref($_[0]);
        }
        else {
            #   untie and rebless into master class
            #untie $_[0];
            bless $_[0], "String::Divert";
        }
    }
    return $old_mode;
}

#   _________________________________________________________________________
#
#   OPERATOR OVERLOADING API
#   _________________________________________________________________________
#

package String::Divert::__OVERLOAD__;

our @ISA       = qw(Exporter String::Divert);
our @EXPORT    = qw();
our @EXPORT_OK = qw();

#   define operator overloading
use overload (
     '""'       => \&op_string,
     'bool'     => \&op_bool,
     '0+'       => \&op_numeric,
     '.'        => \&op_concat,
     '.='       => \&op_append,
     '*='       => \&op_fold,
     '<>'       => \&op_unfold,
     '>>'       => \&op_divert,
     '<<'       => \&op_undivert,
     '='        => \&op_copyconst,
    #'${}'      => \&op_deref_string,
    #'%{}'      => \&op_deref_hash,
    #'nomethod' => \&op_unknown,
     'fallback' => 0
);

#sub TIESCALAR ($$) {
#    my ($class, $self) = @_;
#    bless $self, $class;
#    return $self;
#}

#sub UNTIE ($) {
#    my ($self) = @_;
#    return;
#}

#sub FETCH ($) {
#    my ($self) = @_;
#    return $self;
#}

#sub STORE ($$) {
#    my ($self, $other) = @_;
#    return $self if (ref($other));
#    $self->assign($other);
#    my $dummy = ref($self);
#    return $self;
#}

#sub op_deref_string ($$$) {
#    my $self = shift;
#    return $self;
#}

#sub op_deref_hash ($$$) {
#    my $self = shift;
#    return $self;
#}

sub op_copyconst {
    my ($self, $other, $reverse) = @_;
    if ($self->{copying} eq 'pass') {
        #   object is just passed-through
        return $self;
    }
    else {
        #   object is recursively cloned
        return $self->clone();
    }
}

sub op_string ($$$) {
    my ($self, $other, $rev) = @_;
    return $self->string();
}

sub op_bool ($$$) {
    my ($self, $other, $reverse) = @_;
    return $self->bool();
}

sub op_numeric ($$$) {
    my ($self, $other, $reverse) = @_;
    return $self->string();
}

sub op_concat ($$$) {
    my ($self, $other, $reverse) = @_;
    return ($reverse ? $other . $self->string() : $self->string() . $other);
}

sub op_append ($$$) {
    my ($self, $other, $reverse) = @_;
    $self->append($other);
    return $self;
}

sub op_fold ($$$) {
    my ($self, $other, $reverse) = @_;
    $self->fold($other);
    return $self;
}

sub op_unfold ($$$) {
    my ($self, $other, $reverse) = @_;
    $self->unfold;
    return $self;
}

#sub op_folding ($$$) {
#    my ($self, $other, $reverse) = @_;
#    $self->folding($other);
#    return $self;
#}

sub op_divert ($$$) {
    my ($self, $other, $reverse) = @_;
    $self->divert($other);
    return $self;
}

sub op_undivert ($$$) {
    my ($self, $other, $reverse) = @_;
    $self->undivert($other);
    return $self;
}

#sub op_diversion ($$$) {
#    my ($self, $other, $reverse) = @_;
#    $self->diversion();
#    return $self;
#}

#sub op_unknown ($$$$) {
#    my ($self, $other, $rev, $op) = @_;
#    print ": op=$op\n";
#    return $self;
#}

1;