##############################################################################  
# tago : Arbitrary Tag Object Perl Module
#   Copyright 2009 David A. Gershman, gershman@dagertech.net                    
#                                                                               
# This program is distributed under the terms of the GNU General                
#   Public License v3.                                                          
#                                                                               
# 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 3 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 program.  If not, see <http://www.gnu.org/licenses/>.        
##############################################################################  



# Arbitrary Tag Object 
package tago;

$VERSION = '1.0.1';

sub new {
    my ( $pkg, %rest ) = @_;
    my @list = ();    # Items that go between the open/close tags
    my @parents = (); # Objects that point to this one
    my $obj = bless {
	'__list'    => \@list,
	'__close'   => -1,   # Whether to use a closing tag
	'__oid'     => '',      # Allegedly unique Object ID
	'__string'  => '',     # Generated string
	'__tag'     => '',      # Tag name used in <xxx...> and </xxx>
	'__parents' => \@parents  
	}, $pkg;

    if ( defined $rest{ '-tag' } ) {
	$obj -> tag( $rest{ '-tag' } );
    } else {
	$obj -> tag( 'none' );
    }
    $obj -> oid( $rest{ '-oid' } ) if ( $rest{ '-oid' } );
    $obj -> close( $rest{ '-close' } );
    $obj -> add2end( $rest{ '-add' } ) if ( $rest{ '-add' } );
    $obj -> setrest( %rest );
    return $obj;
}

# When created, all attributes of a tag are arbitrary.
sub setrest {
    my ( $obj, %r ) = @_;
    my $attr;

    # chuck tags we no longer need, should have been set via 'new'
    delete $r{ '-tag' };
    delete $r{ '-oid' };
    delete $r{ '-close' };
    delete $r{ '-insert' };
    delete $r{ '-add' };
    foreach ( keys %r ) {
	$_ =~ s/^\-//;   # chuck the dashes
	$obj -> { $_ } = $r{ "-$_" };  # Add to the attributes
    }
}

# Set/Get objects Unique ID
sub oid {
    my ( $obj, $n ) = @_;
    
    $obj -> { '__oid' } = $n if ( $n );
    return $obj -> { '__oid' };
}

# Set/Get objects tag name
sub tag {
    my ( $obj, $n ) = @_;
    
    $obj -> { '__tag' } = $n if ( $n );
    return $obj -> { '__tag' };
}

# Set/Get whether tag has a closing tag
#  $n==1 => yes; $n==0 => no; $n==-1 => guess
sub close {
    my ( $obj, $n ) = @_;
    
    $n = $obj -> { '__close' } if ( ! defined $n );
    $obj -> { '__close' } = ( $n == 1 || $n == 0 ) ? 
	$n : guess_close( $obj -> tag() );
    return $obj -> { '__close' };

}

# Return number of items in objects containing list
sub count {
    my ( $obj ) = @_;
    return scalar @{ $obj -> { '__list' } };
}

# Duh.
sub clear {
    my ( $obj ) = @_;

    $obj -> { '__list' } = ();
}

# Generates the tag and all its contents, returns resulting string
sub string {
    my ( $obj ) = @_;
    
    $obj -> generate();
    return $obj -> { '__string' };
}

# Traverses the tags list structures and generates the string
sub generate {
    my ( $obj ) = @_;
    my $key;
    my $string = ( $obj -> tag() eq 'none' ) ? '' : ( '<' . $obj -> tag() );

    # If there is no tag name, then don't bother with attributes.
    if ( $obj -> tag() ne 'none' ) {
	# Add all the attributes
	foreach ( keys %$obj ) {
	    # Skip reserved attributes
	    next if ( /^__/ );
	    next if ( $obj -> { $_ } =~ /^\-$/ );
	    if ( $obj -> { $_ } =~ /^\+$/i ) {
		$string .= " $_";
	    } else {
		$string .= " $_=\"" . $obj -> { $_ } . "\"";
	    }
	}
	$string .= ">";
    }

    # Add all the elements of the list
    foreach $key( @{ $obj -> { '__list' } } ) {
	$string .= 
	    ( ref $key ) ? ( $key -> string() ) : $key;
    }
    # Close the tag if needed.
    $string .= "</" . $obj -> tag() . ">" if ( $obj -> close() );
    $obj -> { '__string' } = $string;
}

# Given a list of attributes, will return a hash with the attributes
#  as keys and the values as values.  In the unique case where the
#  list of attributes requested is in fact only one, we'll return
#  the value itself, not a hash.
sub get_attr {
    my ( $obj, @attrs ) = @_;
    my %values = ();

    # Allow a special case of getting a single attribute
    return $obj -> { $_ } if ( $#attrs == 0 );

    # Else return a hash
    foreach ( @attrs ) {
	$values{ $_ } = $obj -> { $_ };
    }
    return %values;
}

# Takes a collection of attr/value, adds them to the object.
sub set_attr {
    my ( $obj, %rest ) = @_;

    foreach ( keys %rest ) {
	$obj -> { $_ } = $rest{ $_ };
    }
    return 1;
}

# Tries to guess whether the tag should have a closing tag or not.
sub guess_close {
    my ( $t ) = @_;
    
    $t = lc $t;
    return 0 if ( $t eq 'br' ||
		  $t eq 'frame' ||
		  $t eq 'hr' ||
		  $t eq 'img' ||
		  $t eq 'none' );
    return 1;
}

# Return the list of objects with this in their lists.
sub parents {
    my ( $obj ) = @_;

    return @{ $obj -> { '__parents' } };
}

# Find 1st occurance of $oid
sub find {
    my ( $obj, $oid ) = @_;
    my $found = '';

    # Are we it?
    return $obj if ( $obj -> oid() eq $oid );

    # No, then go through my list, recursing on each object.
    foreach ( @{ $obj -> { '__list' } } ) {
	$found = $_ -> find( $oid ) if ( ref( $_ ) );
	return $found if ( $found );
    }
    return '';
}

# Same as find, but returns a list of all $oids in the structure
sub find_all {
    my ( $obj, $oid ) = @_;
    my @found = ();

    push @found, $obj if ( $obj -> oid() eq $oid );
    foreach ( @{ $obj -> { '__list' } } ) {
	push @found, $_ -> find_all( $oid ) if ( ref( $_ ) );
    }
    return @found;
}

# Takes an array of objects/items and adds them to the end of this
#  objects list.
sub add2end {
    my ( $obj, @stuff_to_add ) = @_;
    my $save;

    # Normally I'd just append the @stuff_to_add array to the '__list',
    #  but I want to track the parents, so I need to go through and look
    #  for more objects.
    foreach ( @stuff_to_add ) {
	# Add the new item to our list.
	push @{ $obj -> { '__list' } }, $_;

	# Now add this obj to the items parents list.
	push @{ $_ -> { '__parents' } }, $obj if ( ref( $_ ) );
	
	# Save the item just added so the last one will be
        #  return later
	$save = $_;
    }
    # return the last object added.
    return $save; 
}

# Take an array of items to add and put them on the front.
#  Similar to 'add2end', but opposite end of this object's list
sub add2front {
    my ( $obj, @stuff_to_add ) = @_;
    my $save;

    foreach ( @stuff_to_add ) {
	unshift @{ $obj -> { '__list' } }, $_;
	push @{ $_ -> { '__parents' } }, $obj if ( ref( $_ ) );
	$save = $_;
    }
    return $save; # return the last object added.
}

# Finds an item in our current list with OID $oid and adds provided array
#  items before $oid.
sub add_before {
    my ( $obj, $oid, @stuff_to_add ) = @_;
    my $index, $position;
    my @list = @{ $obj -> { '__list' } }; # want to work with array, not ref
    my @first_part, @second_part;

    # Go through our list and find $oid
    $position = -1;
    for ( $index = 0; $index <= $#list; $index++ ) {
	if ( ref( $list[ $index ] ) &&
	     ( $list[ $index ] -> oid() eq $oid ) ) {
	    $position = $index;
	    last;
	}
    }

    # If $oid was not found, just add2end
    return $obj -> add2end( @stuff_to_add ) if ( $position < 0 );

    # If $oid was found at front, just add2front
    return $obj -> add2front( @stuff_to_add ) if ( $position == 0 );
    
    # Else, we split our list in 2
    @first_part = @list[ 0..$position-1 ];
    @second_part = @list[ $position..$#list ];

    # Set our current list to the first part so we can...
    $obj -> { '__list' } = \@first_part;

    # Just add2end.  This will handle the parent tracking as well.
    $save = $obj -> add2end( @stuff_to_add );
    
    # Now combine the two lists...
    @list = ( @{ $obj -> { '__list' } }, @second_part );
    
    # ...and finally set our current list to the result.
    $obj -> { '__list' } = \@list;
    return $save;  # Just return the last item added.
}

# Similar to add_after, but the $oid is in the first part of the
#  list and not the second.
sub add_after {
    my ( $obj, $oid, @stuff_to_add ) = @_;
    my $index, $position;
    my @list = @{ $obj -> { '__list' } }; 
    my @first_part, @second_part;

    # Find $oid
    $position = -1;
    for ( $index = 0; $index <= $#list; $index++ ) {
	if ( ref( $list[ $index ] ) &&
	     ( $list[ $index ] -> oid() eq $oid ) ) {
	    $position = $index;
	    last;
	}
    }

    # Handle end cases
    return $obj -> add2end( @stuff_to_add ) if ( $position < 0 );
    return $obj -> add2front( @stuff_to_add ) if ( $position == $#list );
    
    # Now insert where desired.
    @first_part = @list[ 0..$position ];
    @second_part = @list[ $position+1..$#list ];
    $obj -> { '__list' } = \@first_part;
    $save = $obj -> add2end( @stuff_to_add );
    @list = ( @{ $obj -> { '__list' } }, @second_part );
    $obj -> { '__list' } = \@list;
    return $save;
}

# Deleting a tag has two different frames of thought.
#   1) Delete the current tag, but leave everything it contains.
#      i.e. Given "<u>NOW</u>", remove the <u></u> tag, but keep "NOW"
#   2) Remove a tag and everything it contains.

# Only removes the tag information, leave data structure in tact.
#  May waste some space, but it keeps from having to process
#  parent lists of all items in the objects lists. 
sub delete_tag_only {
    my ( $obj ) = @_;
    
    # Clear all attributes
    foreach ( keys %$obj ) {
	next if ( /^__/ ); # I'll deal with the private ones
	delete $obj -> { $_ };
    }
    # Now deal with private ones.  I need to deal with them separately
    #  because I want to maintain the data structure.  So in reality
    #  they're not deleted, just initialized.
    $obj -> { '__close' } = 0;
    $obj -> { '__oid' }   = '';
    $obj -> { '__tag' }   = 'none';
    return $obj;
}

# Deletes the object and all its contents
sub delete_all {
    my ( $obj ) = @_;
    my @parents = $obj -> parents();
    my $oid = $obj -> oid();
    my ( $index, $parent );

    # We really just need to delete all references to the object from any
    #  parents.
    foreach $parent ( @parents ) {
	# For each parent, go find the reference to this object 
	#  and remove it.  Actually, the array position in its parents
	#  list is set to ''.  Again, this prevents extra processing
	#  of shifting the array.
	for ( $index = 0; $index < $parent -> count(); $index++ ) {
	    next if ( ! ref( ${ $parent -> { '__list' } }[ $index ] ) );
	    ${ $parent -> { '__list' } }[ $index ] = '' 
		if ( ${ $parent -> { '__list' } }[ $index ] -> oid() eq $oid );
	}
    }
    return 1;
}

# Not really part of a tag, but helpful for parsing template HTML files
#  syntax:  
#      #tag description#
#  Tag description: -attr=val;;{-attr=val;;...;;-attr=val}
#
sub phadd {
    my ( $obj, $file ) = @_;
    my @static = split( /\#[^\#]+\#/, $file );
    my @tags = $file =~ /\#([^\#]+)\#/g;
    my $i;
    my @pairs = ();
    my %rest = ();
    my $attr, $val;

    ( $first, $second ) = ( ! $static[0] ) ? ( \@tags, \@static ) : ( \@static, \@tags );
    # Change all tag descriptions to objects
    for ( $i = 0; $i <= $#tags; $i++ ) {
	@pairs = split ';;', $tags[ $i ];
	$tags[ $i ] = new tago();
	foreach ( @pairs ) {
	    ( $attr, $val ) = split /\s*\=\s*/;
	    if ( $attr =~ /^\-add$/i ) {
		$tags[ $i ] -> add( $val );
	    } elsif ( $attr =~ /^\-oid$/i ) {
		$tags[ $i ] -> oid( $val );
	    } elsif ( $attr =~ /^\-close$/i ) {
		$tags[ $i ] -> close( $val );
	    } elsif ( $attr =~ /^\-tag$/i ) {
		$tags[ $i ] -> tag( $val );
	    } else {
		$rest{ $attr } = $val;
	    }
	}
	$tags[ $i ] -> setrest( %rest );
    }

    $obj -> add( shift @$first ) if (( scalar @$first ) > ( scalar @$second ));
    $i = scalar @$first;
    while( $i > 0 ) {
        $obj -> add( shift @$second );
        $obj -> add( shift @$first );
        $i--;
    }
    return 1;
}

sub phadd_file {
    my ( $obj, $filename ) = @_;
    my @lines;

    open( F, $filename ) or do {
	return 0;
    };
    @lines = <F>;
    close( F );
    $obj -> phadd( join( '', @lines ) );
    return 1;
}

# For convenience, have some aliases for common subs
sub prune {
    $_[0] -> delete_all();
}

sub delete {
    $_[0] -> delete_tag_only();
}

sub add {
    my ( $obj, @rest ) = @_;
    return $obj -> add2end( @rest );
}


1;