view release on metacpan or  search on metacpan

t/Client.pm  view on Meta::CPAN

######################################################
sub for_window
{
    my( $self, $accume, $phase ) = @_;
    Carp::carp "Must be parent" if $self->{parent} or $self->{name};

    foreach my $id ( keys %$accume ) {
        my $win = $self->{windows}{ $id };
        $win = $win->{browser} if $win;
        my $name = $id;
        if( $id eq '' ) {
            $win = $self;
            $name = 'main window';
        }
    
        ok( $win, "Instructions for |$name|" ) or die "PAIN FOLLOWS";
        $win->handle_resp( $accume->{ $id }, $phase );
    }
}

######################################################
sub handle_one
{
    my( $self, $op, $id, @args ) = @_;
    return unless $op;
    if( $op eq 'ERROR' ) {
        die $args[0];
    }

    return if $id and $self->{deleted}{ $id };
    if( $op eq 'SID' ) {
        ok( !$self->{SID}, "New SID $id" );
        $self->{SID} = $id;
    }
    elsif( $op eq 'boot' ) {
        ok( !$self->{boot}, "Boot message '$id'" );
        $self->{boot} = $id;
    }
    elsif( $op eq 'textnode' ) {
        ok( defined( $args[1] ), "Got a $id.textnode" );
        ok( $self->{NODES}->{$id}, " ... and we have its parent ($id)" )
                or die "$self->NODES=", 
                           sort keys %{ $self->{NODES} };
        my $parent = $self->{NODES}->{$id}{zC};
        if( $args[0] < 0 ) {
            push @$parent, { tag=>'textnode', nodeValue=>$args[1] };
        } 
        else {
            ok( ( $args[0] <= @{$parent} ), " ... and this isn't impossible" );
            my $tn = $parent->[ $args[0] ];
            if( $tn and $tn->{tag} eq 'textnode' ) {
                $tn->{nodeValue} = $args[1];
            }
            else {
                $parent->[ $args[0] ] =
                    { tag=>'textnode', nodeValue=>$args[1] };
            }
        }
    }
    elsif( $op eq 'cdata' ) {
        ok( defined( $args[1] ), "Got a cdata $id" );
        ok( $self->{NODES}->{$id}, " ... and we have its parent ($id)" );
        my $parent = $self->{NODES}->{$id}{zC};
        ok( ( $args[0] <= @{$parent} ), " ... and this isn't way out there" );
        if( $args[0] < 0 ) {
            push @$parent, { tag=>'cdata', cdata=>$args[1] };
        }
        else {
            my $tn = $parent->[ $args[0] ];
            if( $tn and $tn->{tag} eq 'cdata' ) {
                $tn->{nodeValue} = $args[1];
            }
            else {
                $parent->[ $args[0] ] =
                    { tag=>'cdata', cdata=>$args[1] };
            }
        }
    }
    elsif( $op eq 'new' ) {
        ok( ! $self->{NODES}->{$id}, "New node $id" );
        ok( $args[0], " ... with a tag type" );
        my $new = $self->{NODES}->{$id} = 
                    { tag => $args[0], id=>$id, zC=>[] };
        if( $args[1] ) {
            my $parent = $self->{NODES}->{$args[1]};
            ok( $parent, " ... and we have its parent ($args[0] wants $args[1])" );

            if( $args[2] < 0 ) {
                $parent->{zC} ||= [];
                push @{ $parent->{zC} }, $new;
            }
            else {
                my $old = $parent->{zC}[ $args[2] ];
                if( $old ) {
                    delete $self->{NODES}->{ $old->{id} };
                }

                $parent->{zC}[ $args[2] ] = $new;
            }
        }
        if( ($new->{tag}||'') eq 'window' ) {
            ok( !$self->{W}, "New window" );
            $self->{W} = $new;
        }
    }
    elsif( $op eq 'set' ) {
        ok( 2==@args, "Going to set attribute $args[0]" );
        my $m = 'an existing node'; 
        $m = $args[1] if $args[0] eq 'id';
        ok( $self->{NODES}->{$id}, " ... on $m" )
                or die "Where is $id in ", join ', ', sort keys %{ $self->{NODES} }, 
                                Dumper [ $op, $id, @args ];

        isnt( $self->{NODES}->{$id}{tag}, 'textnode', 
                        "One can't reference a text node!" );

        if( $args[0] eq 'id' ) {
            my $N = delete $self->{NODES}->{$id};
            DEBUG and diag( "$N->{id} -> $args[1]" );
            $N->{id} = $args[1];
            $self->{NODES}->{ $N->{id} } = $N;
        }
        else {
            $self->{NODES}->{$id}{$args[0]} = $args[1];
        }
    }
    elsif( $op eq 'remove' ) {
        ok( 1==@args, "Going to remove attribute $args[0]" );
        ok( $self->{NODES}->{$id}, " ... on an existing node" )
                or die "Where is $id in ", join ', ', sort keys %{ $self->{NODES} }, 
                                Dumper [ $op, $id, @args ];

        delete $self->{NODES}->{$id}{$args[0]};
    }
    elsif( $op eq 'bye' ) {

t/Client.pm  view on Meta::CPAN

        ok( $parent, " ... and we know the parent of $old->{id}" )
                or die "We need to know the parent!";
        ok( ( $index < @{ $parent->{zC} } ), " ... in range" );

        my $new = {
                    tag => 'iframe',
                    id  => "IFRAME-$old->{id}",
                    src => { type      => 'XUL-from', 
                             source_id => $old->{id}
                           }
                };
        ok( !$self->{NODES}->{$new->{id}}, " ... never been framified" );
        $self->{NODES}->{$new->{id}} = $new;

        my $node = splice @{ $parent->{zC} }, $index, 1, $new;
        is( $old, $node, " ... it's right node" );
        $self->drop_node( $node );
    }
    elsif( $op eq 'timeslice' ) {
        # ignore
    }
    elsif( $op eq 'popup_window' ) {
        $self->popup_window( $id, @args );
    }
    elsif( $op eq 'close_window' ) {
        push @{ $self->{close_window} }, $id;
    }
    elsif( $op eq 'timeslice' ) {
        # ignore it
    }
    elsif( $op eq 'style' ) {
        ok( 2==@args, "Going to set style $args[0]" );
        ok( $self->{NODES}->{$id}, " ... on an existing node" )
                or die "Where is $id in ", join ', ', sort keys %{ $self->{NODES} }, 
                                Dumper [ $op, $id, @args ];

        my $N = $self->{NODES}->{$id};
        
        isnt( $N->{tag}, 'textnode', "One can't set the style of a text node!" );
        
        $self->{style} ||= {};
        if( not ref $N->{style} ) {
            $N->{style} = { map { split /:\s*/, $_, 2 } 
                                split /;\s*/, $N->{style} #**
                          };
        }
        $N->{style}{$args[0]} = $args[1];
    }
    else {
         die "What do i do with op=$op";
    }
}

######################################################
sub find_parent
{
    my( $self, $node ) = @_;
    return unless defined $node;
    foreach my $N ( values %{$self->{NODES}} ) {
        next if $N->{tag} eq 'textnode' or $N->{tag} eq 'cdata';
        use Data::Dumper;
        die Dumper $N unless $N->{zC};
        for( my $q1=0; $q1 < @{ $N->{zC} }; $q1++ ) {
            unless( defined $N->{zC}[ $q1 ] ) {
                # die "$q1=", Dumper $N->{zC};
                next;
            }
            next unless $N->{zC}[$q1] == $node;
            return $N, $q1 if wantarray;
            return $N;
        }
    }
    return;
}

############################################################
sub is_visible
{
    my( $self, $node ) = @_;
    $node = $self->find_ID( $node ) unless ref $node;
    return unless $node;
    my $style = $self->style( $node );
    return not ( $style =~ /display:\s*none/ );
}

######################################################
sub style
{
    my( $self, $node ) = @_;
    my $S = $node->{style};
    return '' unless $S;
    return $S unless ref $S;
    
    return join "\n", map { "$_: $S->{$_};" } sort keys %$S;
}


######################################################
sub nodeText
{
    my( $self, $node ) = @_;
    return $node->{nodeValue} if $node->{tag} eq 'textnode';
    my @ret;
    foreach my $N ( @{ $node->{zC} } ) {
        push @ret, $self->nodeText( $N );
    }
    return @ret if wantarray;
    return join " ", @ret;
}

######################################################
sub drop_node
{
    my( $self, $node ) = @_;
    if( $node->{id} ) {
        delete $self->{NODES}->{ $node->{id} };
        $self->{deleted}{ $node->{id} } = 1;
    }

    return if not $node->{tag} or $node->{tag} eq 'textnode' or $node->{tag} eq 'cdata';
    foreach my $C ( @{ $node->{zC} } ) {
        $self->drop_node( $C );
    }
    $node->{zC} = [];
}

######################################################
sub root_uri
{
    my( $self ) = @_;
    return URI->new( "http://$self->{HOST}:$self->{PORT}/" );
}

######################################################
sub base_uri
{
    my( $self ) = @_;
    return URI->new( "http://$self->{HOST}:$self->{PORT}/xul" );
}

######################################################
sub default_args
{
    my( $self ) = @_;
    return ( version=>1, window=>$self->{name}, reqN=> $self->{R}++ );
}

######################################################
sub boot_uri
{
    my( $self ) = @_;
    my $URI = $self->base_uri;
    $URI->query_form( $self->boot_args );
    return $URI;
}

######################################################
sub boot_args
{
    my( $self, $button ) = @_;
    return { $self->default_args, app=> $self->{APP} };
}

######################################################
sub list_ID
{
    my( $self ) = @_;
    my @list = sort grep { !/^PX/ } keys %{ $self->{NODES} };
    return join ', ', @list unless wantarray;
    return @list;
}

sub find_by_tag
{
    my( $self, $tag ) = @_;

    return map { $self->find_ID( $_ ) } $self->list_by_tag( $tag );
}

sub list_by_tag