The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl

use strict;
$^W = 1;

my $counter = 0;

# takes a true/false value as first arg, prints "[not] ok ..." followed
# by the second arg
sub ok {
    $counter++;
    print ''.($_[0] ? 'ok ' : 'not ok ').$counter."\t$_[1]\n";
    return $_[0];
}

sub is {
    ok($_[0] eq $_[1], $_[2]) ||
      print "# got: [$_[0]]\n# exp: [$_[1]]\n";
}    

# compares first two args deeply, prints "[not] ok ..." followed by third arg
# NB *only* handles scalars, hashes and arrays
sub is_deeply {
    my($msg, @args) = reverse(@_);
    ok(_is_deeply(@args), $msg);
}

sub _is_deeply {
    my @args = @_;
    return 0 unless(ref($args[0]) eq ref($args[1]));
    if(ref($args[0]) eq '') {
        return ($args[0] eq $args[1]);
    } elsif(ref($args[0]) eq 'ARRAY') {
        return _is_deeply_arrays(@args);
    } elsif(ref($args[0]) eq 'HASH') {
        return _is_deeply_hashes(@args);
    } else {
        return 0
    }
}

sub _is_deeply_arrays {
    return 0 if(@{$_[0]} != @{$_[1]}); # different sizes
    foreach my $i (0 .. $#{$_[0]}) {
        return 0 if(!_is_deeply($_[0]->[$i], $_[1]->[$i]));
    }
    return 1;
}

sub _is_deeply_hashes {
    my %arg1 = %{$_[0]};
    my %arg2 = %{$_[1]};
    return 0 if((keys %arg1) != (keys %arg2)); # different sizes
    return 0 if(!_is_deeply_arrays(              # different keys
        [sort keys %arg1], [sort keys %arg2]
    ));
    return 0 if(!_is_deeply_arrays(              # different values
        [@arg1{sort keys %arg1}], [@arg2{sort keys %arg1}]
    ));
    return 1;
};

# strips the 'attrib' key out of any hashes in a structure
sub strip_attribs {
    return unless(ref($_[0]));
    if(ref($_[0]) eq 'ARRAY') {
        foreach (@{$_[0]}) { strip_attribs($_) }
    } elsif(ref($_[0]) eq 'HASH') {
        delete $_[0]->{attrib};
        if($_[0]->{type} eq 'e') {
	    foreach (@{$_[0]->{content}}) { strip_attribs($_) }
	}
    }
}

1;