File Coverage

blib/lib/POE/XUL/Node.pm

Criterion	Covered	Total	%
statement	304	354	85.8
branch	110	162	67.9
condition	32	46	69.5
subroutine	59	67	88.0
pod	27	42	64.2
total	532	671	79.2

package POE::XUL::Node;
# $Id: Node.pm 1566 2010-11-03 03:13:32Z fil $
# Copyright Philip Gwyn 2007-2010.  All rights reserved.
# Based on code Copyright 2003-2004 Ran Eilam. All rights reserved.



use strict;
use warnings;
use Carp;
use Scalar::Util qw( blessed );
use POE::XUL::Constants;
use POE::XUL::TextNode;
use POE::XUL::CDATA;
use POE::XUL::Style;
use POE::XUL::Window;
use Storable qw( dclone );
use HTML::Entities qw( encode_entities_numeric );

use constant DEBUG => 0;

our $VERSION = '0.0601';
our $CM;

my $ID = 0;

my @XUL_ELEMENTS = qw(
      ArrowScrollBox Box Button Caption CheckBox ColorPicker Column Columns
      Deck Description Grid Grippy GroupBox HBox Image Label ListBox
      ListCell ListCol ListCols ListHead ListHeader ListItem Menu MenuBar
      MenuItem MenuList MenuPopup MenuSeparator ProgressMeter Radio
      RadioGroup Row Rows ScrollBar Seperator Spacer Splitter Stack StatusBar
      StatusBarPanel Tab TabBox TabPanel TabPanels Tabs TextBox ToolBar
      ToolBarButton ToolBarSeperator ToolBox VBox Window

      Tree TreeChildren TreeItem TreeRow TreeCols TreeCol TreeCell
      TreeSeparator Template Rule
);

# my %XUL_ELEMENTS = map { $_ => 1 } @XUL_ELEMENTS;

my @HTML_ELEMENTS = qw(
    HTML_Pre HTML_H1 HTML_H2 HTML_H3 HTML_H4 HTML_A HTML_Div HTML_Br HTML_Span
);

my @DEFAULT_LABEL =

my %DEFAULT_ATTRIBUTE = map { $_ => 'label' } qw(
        caption button menuitem radio listitem
    );


my @OTHER_ELEMENTS = qw(
    Script Boot RawCmd pxInstructions
);

my %LOGICAL_ATTS = (
        selected => 1,
        disabled => 1,
        autoFill => 1,
        autocheck => 1,
        editable => 1,
#        checked => 1
    );

# creating --------------------------------------------------------------------

##############################################################
sub import
{
    my( $package ) = @_;
	my $caller = caller();
	no strict 'refs';
	# export factory methods for each xul element type
	foreach my $sub ( @XUL_ELEMENTS, @HTML_ELEMENTS ) {
        my $tag = lc $sub;
        $tag =~ s/^html_/html:/;
        # delete ${"${caller}::$other"};
		*{"${caller}::$sub"} = sub
			{ return scalar $package->new(tag => $tag, @_) };
	}
	foreach my $other (@OTHER_ELEMENTS) {
        # delete ${"${caller}::$other"}
        *{"${caller}::$other"} = sub
            { return scalar $package->can("$other")->( $package, @_ ) };
    }

	# export the xul element constants
	foreach my $constant_name (@POE::XUL::Node::Constants::EXPORT) {
        *{"${$caller}::$constant_name"} = *{"$constant_name"}
    }
}

##############################################################
sub new
{
	my ($class, @params) = @_;

	my $self;
    if( ($params[0]||'') eq 'tag' and lc($params[1]||'') eq 'window' ) {
        $self = bless {attributes => {}, children => [], events => {}},
                        'POE::XUL::Window';
    } else {
        $self = bless {attributes => {}, children => [], events => {}}, $class;
    }

    my $id;
    ( $id, @params ) = $self->__find_id( @params );

    $id = $self->__auto_id( $id );
    $CM->before_creation( $self ) if $CM;

    if( DEBUG and not $CM and $INC{'POE/XUL/ChangeManager.pm'} ) {
        Carp::cluck "Building a POE::XUL::Node, but no ChangeManager avaiable";
    }

	while (my $param = shift @params) {
		if( ref $param ) {
            $self->appendChild( $param );
        }
		elsif( $param =~ /\s/ or 0==@params ) {
            $self->defaultChild( $param );
        }
		elsif ($param eq 'textNode' ) {
            $self->appendChild( shift @params );
        }
		elsif ($param =~ /^[a-z]/) {
            $self->setAttribute( $param => shift @params );
        }
		elsif ($param =~ /^[A-Z]/) {
            $self->attach($param => shift @params );
        }
		else {
            croak "unrecognized param: [$param]"
        }
	}

	return $self;
}

##############################################################
# Scan ->new()'s parameters, trying to pull out an ID
sub __find_id
{
    my( $self, @params ) = @_;
    my( $id, @out );
	while (my $param = shift @params) {
		if( ref $param or $param =~ /\s/ or 0==@params ) {
            push @out, $param;
        }
		else {
            if( $param eq 'id' ) {
                $id = shift @params;
                next;
            }
            push @out, $param, shift @params;
        }
	}
    return ( $id, @out );
}

##############################################################
sub Script {
    my $class = shift;
    # warn "class=$class";
    # warn "script=", join "\n", @_;
    my $cdata = POE::XUL::CDATA->new( join "\n", @_ );
    return $class->new( tag=>'script', type=>'text/javascript', $cdata );
}

##############################################################
# Boot message
sub Boot
{
    my( $class, $msg ) = @_;
    if( $CM ) {
        $CM->Boot( $msg );
    }
    my $server = $POE::XUL::Application::server;
    if( $server ) {
        $server->Boot( $msg );
    }
    return;
}

##############################################################
# Send a raw command to Runner.js
sub RawCmd
{
    my( $class, $cmd ) = @_;
    if( $CM ) {
        $CM->Prepend( $cmd );
    }
    return;
}

##############################################################
# Instructions to Runner.js, via ChangeManager
sub pxInstructions
{
    my( $self, @inst ) = @_;
    unless( $CM ) {
        unless( $INC{ 'Test/More.pm' } ) {
            # carp "There is no ChangeManager.  Instructions ignored.";
        }
        return;
    }

    my $rv;
    foreach my $inst ( @inst ) {
        $rv = $CM->instruction( $inst );
    }
    return $rv;
}


##############################################################
## Assign an ID as soon as possible, so that the CM and State
## will see it
sub __auto_id
{
    my( $self, $id ) = @_;
    unless( $id ) {
        $id = "PXN$ID";
        $ID++;
        $self->{default_id} = $id;
    }
    $self->{attributes}{id} = $id;
    return $id;
}

##############################################################
sub build_text_node
{
    my( $self, $text ) = @_;
    my $textnode = POE::XUL::TextNode->new;

    $textnode->nodeValue( $text );
    return $textnode;
}
*createTextNode = \&build_text_node;


##############################################################
sub textNode
{
    my( $self, $text ) = @_;

    # Find the last text node
    my $old;
    foreach my $C ( $self->children ) {
        next unless $C->isa( 'POE::XUL::TextNode' );
        $old = $C;
    }

    unless( 2==@_ ) {
        return unless $old;
        return $old->nodeValue;
    }

    if( $old and ref $text ) {
        $self->replaceChild( $text, $old );
        return $text->nodeValue if blessed $text;
        return $text;
    }
    elsif( $old ) {
        return $old->nodeValue( $text );
    }
    else {
        return $self->appendChild( $text )->nodeValue;
    }
}


##############################################################
sub getItemAtIndex
{
    my( $self, $index ) = @_;
    return if not defined $index or $index < 0;

    if( $self->tag eq 'menulist' ) {
        $self = $self->firstChild;
    }

    my $N = 0;
    foreach my $I ( $self->children ) {
        my $t = $I->tag;
        next unless $t eq 'listitem' or $t eq 'menuitem';
        return $I if $N == $index;
        $N++;
    }
    return;
}
*get_item = \&getItemAtIndex;

# attribute-like method invocation --------------------------------------------
sub mk_method
{
    my( $name ) = @_;
    return sub {
            my $self = shift;
            return unless $CM;
            $CM->after_method_call( $self, $name, [@_] );
        };
}
*scrollTo      = mk_method( 'scrollTo' );
*scrollBy      = mk_method( 'scrollBy' );
*scrollToLine  = mk_method( 'scrollToLine' );
*scrollByLine  = mk_method( 'scrollByLine' );
*scrollByPage  = mk_method( 'scrollByPage' );
*scrollByIndex = mk_method( 'scrollByIndex' );


# attribute handling ----------------------------------------------------------

##############################################################
sub attributes
{
    my( $self ) = @_;
    my $ret = dclone $self->{attributes};
    return %$ret if wantarray;
    return $ret;
}

##############################################################
sub get_attribute
{
    my( $self, $key ) = @_;
    if( $LOGICAL_ATTS{ $key } ) {
        return unless $self->{attributes}{$key};
        # 'false' is still true, in Perl
        return if $self->{attributes}{$key} eq 'false';
    }

    return $self->style if $key eq 'style';
    return $self->{attributes}{$key};
}
*getAttribute = \&get_attribute;


##############################################################
sub set_attribute
{
    my( $self, $key, $value ) = @_;
    return $self->style( $value ) if $key eq 'style';
    if( $key eq 'tag' ) {
        $value = lc $value;
        $value =~ s/^html_/html:/;
        $value =~ s/^xul://;
    }

    if( $LOGICAL_ATTS{ $key } ) {
        if( ! $value or $value eq 'false' ) {
            $self->remove_attribute( $key );
            return;
            # remove_attribute() informs the CM, we don't have to
        }
        # 2008-09 : the following is a tad silly...
        $value = $value ? 'true' : 'false';
    }

    if( DEBUG and $key eq 'id' ) {
        carp $self->id, ".$key=$value";
    }

    if( $key eq 'value' ) { # and $self->tag eq 'menulist' ) {
            # Carp::cluck( $self->tag . ".value=$value" );
    }

    $self->{attributes}{$key} = $value;
    $CM->after_set_attribute( $self, $key, $value ) if $CM;
    return $value;
}
*setAttribute = \&set_attribute;

##############################################################
sub remove_attribute
{
    my( $self, $key ) = @_;
#    if( $key eq 'value' and $self->tag eq 'menulist' ) {
#        Carp::cluck( $self->tag . ".removeAttribute('value')" );
#    }
    croak "You may not remove the tag attribute" if $key eq 'tag';
    $CM->after_remove_attribute( $self, $key ) if $CM;
    delete $self->{attributes}{ $key };
}
*removeAttribute = \&remove_attribute;

##############################################################
sub is_window { 0 }

##############################################################
*id = __mk_accessor( 'id' );
*tagName = __mk_accessor( 'tag' );
#*textNode = __mk_accessor( 'textNode' );

sub __mk_accessor
{
    my( $tag ) = @_;
    return sub {
        my( $self, $value ) = @_;
        if( @_ == 2 ) {
            return $self->setAttribute( $tag, $value );
        }
        else {
            return $self->{attributes}{$tag};
        }
    }
}

##############################################################
sub style {
    my( $self, $value ) = @_;
    if( 1==@_ ) {
        return $self->get_style;
    }
    else {
        return $self->set_style( $value );
    }
}

sub get_style
{
    my( $self ) = @_;
    return $self->{style_obj} if $self->{style_obj};
    $self->{style_obj} = POE::XUL::Style->new( $self->{attributes}{style} );
    $CM->after_new_style( $self ) if $CM;
    return $self->{style_obj};
}

sub set_style
{
    my( $self, $value ) = @_;
    $self->{attributes}{style} = "$value";
    if( blessed $value ) {
        $self->{style_obj} = $value;
        $CM->after_new_style( $self ) if $CM;
    }
    else {
        delete $self->{style_obj};
        # do the following to provoke a ->after_new_style();
        $self->get_style;
    }
    return;
}

##############################################################
sub AUTOLOAD {
	my( $self, $value ) = @_;
	my $key = our $AUTOLOAD;
	return if $key =~ /DESTROY$/;
	$key =~ s/^.*:://;
#    Carp::confess $key;
    if( $key =~ /^[a-z]/ ) {
        if( @_ == 1 ) {
            return $self->getAttribute( $key );
        }
        else {
            return $self->setAttribute( $key, $value );
        }
    }
    elsif( $key =~ /^[A-Z]/ ) {
        $self->add_child( __PACKAGE__->new(tag => $key, @_[ 1..$#_ ] ) );
    }
    croak __PACKAGE__. "::AUTOLOAD cannot find method $key";
}

##############################################################
sub hide
{
    my( $self ) = @_;
    $self->style->display( 'none' );
}

##############################################################
sub show
{
    my( $self ) = @_;
    $self->style->display( '' );
}

sub hidden
{
    my( $self ) = @_;
    return $self->style->display eq 'none';
}

# compositing -----------------------------------------------------------------

sub children    { wantarray? @{shift->{children}}:
                             [@{shift->{children}}] }
sub child_count { scalar @{shift->{children}} }
sub hasChildNodes { return 0!= scalar @{shift->{children}} }
sub first_child { shift->{children}->[0] }
*firstChild     = \&first_child;
sub get_child   { shift->{children}->[pop] }
sub last_child { shift->{children}->[-1] }
*lastChild     = \&last_child;

##############################################################
sub add_child {
	my ($self, $child, $index) = @_;
    # This is a huge speed up, but breaks the Aspect stuff
#    unless( defined $index ) {
#        push @{$self->{children}}, $child;
#        return $child;
#    }
	my $child_count = $self->child_count;
	$index = $child_count unless defined $index;
	croak "index out of bounds: [$index:$child_count]"
		if ($index < 0 || $index > $child_count);

    if( $self->{children}[$index] ) {
        $self->remove_child( $index );
    }

	$self->_add_child_at_index($child, $index);
	return $child;
}
sub appendChild
{
    my( $self, $child ) = @_;
    $child = $self->createTextNode( $child ) unless ref $child;
	my $index = $self->child_count;
	$self->_add_child_at_index( $child, $index );
}

sub defaultChild
{
    my( $self, $text ) = @_;
    my $d_att = $DEFAULT_ATTRIBUTE{ lc $self->{attributes}{tag} || '' };
    if( $d_att ) {
        $self->setAttribute( $d_att => $text );
        return;
    }

    my $child = $self->createTextNode( $text );
	my $index = $self->child_count;
	$self->_add_child_at_index( $child, $index );
}

##############################################################
sub replaceChild {
	my ($self, $new, $old) = @_;

	my ($oldNode, $index) = $self->_compute_child_and_index($old);
    $CM->before_remove_child( $self, $oldNode, $index ) if $CM;
	splice @{$self->{children}}, $index, 1, $new;
    $CM->before__add_child_at_index( $self, $new, $index ) if $CM;
	$old->dispose;
	return $self;
}

##############################################################
sub remove_child {
	my ($self, $something) = @_;

	my ($child, $index) = $self->_compute_child_and_index($something);

    unless( $child and $index < @{ $self->{children} } ) {
        Carp::carp "Attempt to remove an unknown child node" unless $ENV{AUTOMATED_TESTING};
        return;
    }

    # warn "remove_child id=", $child->{attributes}{id};
    $CM->before_remove_child( $self, $child, $index ) if $CM;
	splice @{$self->{children}}, $index, 1;
	$child->dispose if blessed $child;
	return $self;
}

*removeChild = \&remove_child;

##############################################################
sub get_child_index
{
	my ($self, $child) = @_;
	my $index = 0;
    foreach my $C ( @{ $self->{children} } ) {
        return $index if $child eq $C;
        $index++;
    }
    confess 'child not in parent';
}

##############################################################
# computes child and index from child or index
sub _compute_child_and_index
{
	my ($self, $something) = @_;
	my $is_node = ref $something;
	my $child   = $is_node? $something: $self->get_child($something);
	my $index   = $is_node? $self->get_child_index($something): $something;
	return wantarray? ($child, $index): $child;
}

sub _add_child_at_index {
	my ($self, $child, $index) = @_;
    my $N = $#{ $self->{children} };
    my $trueindex;
    if( $index > $N ) {
        $index = -1;
        push @{ $self->{children} }, $child;
        $trueindex = $#{ $self->{children} };
    }
    else {
        splice @{$self->{children}}, $index, 0, $child;
    }
    if( $CM ) {
        $CM->after__add_child_at_index( $self, $child, $index );
        # after__add_child needs $index to be -1 for appends, so that they
        # work in Runner.  However, the state needs to remember the real, true
        # index, so we set it afterwards.
        # 2009-02: the problem with this is that the index might differ from
        # what is happening in the client.  Client should send the index back
        # to us.  TODO when we implement AJAX
        if( defined $trueindex ) {
            $CM->set_trueindex( $self, $child, $trueindex );
        }
    }
	return $child;
}

##############################################################
sub getElementById
{
    my( $self, $id ) = @_;
    return $id if blessed $id;      # act like prototype's $()
    croak "getElementById may only be invoked on a Window"
            unless $self->is_window;
    return $CM->getElementById( $id );
}

# event handling --------------------------------------------------------------

sub attach {
    my( $self, $name, $listener ) = @_;

    my $state;

    my $server = $POE::XUL::Application::server;
    if( $server ) {
        # auto-create the handler in the application
        $state = $server->attach_handler( $self, $name, $listener );
    }
    else {
        $state = $listener||$name;
    }
    DEBUG and warn $self->id, ".$name = $state";
    return unless $state;
    $self->{events}->{ $name } = $state;
    return 1;
}
*addEventListener = \&attach;

sub detach {
	my ($self, $name) = @_;
	my $listener = delete $self->{events}->{$name};
	croak "no listener to detach: $name" unless $listener;
    # TODO: remove the POE state if we auto-created it?
}
*removeEventListener = \&detach;

sub event {
	my ($self, $name) = @_;
	my $listener = $self->{events}->{ $name };
	return $listener;
}

# disposing ------------------------------------------------------------------

# protected, used by sessions and by parent nodes to free node memory
# event handlers could cause reference cycles, so we free them manually
sub dispose {
	my $self = shift;
    $self->{disposed} = 1;
    delete $self->{style_obj};
	$_->dispose for grep { blessed $_ } $self->children;
	delete $self->{events};
    $self->{children} = [];
    # TODO: remove any events that auto-created handler states
}
*destroy = \&dispose;

sub is_destroyed { !shift->{events} }

sub DESTROY
{
    my( $self ) = @_;
    # carp "DESTROY ", ($self->id||$self);
    $CM->after_destroy( $self ) if $CM;
}



#######################################################################
sub as_xml {
	my $self       = shift;
	my $level      = shift || 0;
	my $tag        = lc $self->tag;
    $tag =~ s/_/:/;
	my $attributes = $self->attributes_as_xml;
	my $children   = $self->children_as_xml($level + 1);
#	my $indent     = $self->get_indent($level);
    my $nl         = ( $tag =~ /^((h|v|group)box)|(grid|row|(field-(name|value)))$/ ? "\n" : "" );
    return qq[<$tag$attributes${\( $children? ">$nl$children$nl];
}

sub attributes_as_xml {
	my $self       = shift;
	my %attributes = $self->attributes;
	my $xml        = '';

    delete $attributes{id} if $self->{default_id} and
                              $attributes{id} eq $self->{default_id};

    foreach my $k ( keys %attributes ) {
        next if defined $attributes{ $k };
        warn $self->id."/$k is undef";
        $attributes{ $k } = '';
    }
	$xml .= qq[ $_='${\( encode_entities_numeric( $self->$_, "\x00-\x1f<>&\'\x80-\xff" ) )}']
		for grep { $_ ne 'tag' and $_ ne 'textNode' } keys %attributes;
#    die $xml if $xml =~ /\n/;
	return $xml;
}

sub children_as_xml {
	my $self   = shift;
	my $level  = shift || 0;
#	my $indent = $self->get_indent($level);
	my $xml    = '';
#	$xml .= qq[\n$indent${\( $_->as_xml($level) )}] for $self->children;
	$xml .= qq[${\( blessed $_ ? $_->as_xml($level) : $_ )}] for $self->children;
	return $xml;
}

sub get_indent { ' ' x (3 * pop) }

1;

__END__