# This is a Perl5 file
# ChangeLog
#
# 2005-09-06
# * new class Perl6::Container::Hash::Native
#
# 2005-09-05
# * delete hash element
#
# 2005-08-31
# * New methods: tied(), keys(), values(), pairs(), kv()
# * Fixed elems(), buckets() to return boxed Int, Str
# * hash iterator (firstkey/nextkey) works
#
# 2005-08-19
# * New Perl6 class 'Hash'
#
# 2005-08-18
# * New Perl5 class "Perl6::Container::Hash::Object"
# implements a hash in which the keys can be objects
#
# 2005-08-14
# * added functions clone(), elems(), buckets()
# TODO - warn for odd number of elements, on construction
# TODO - keys(), values(), pairs(), kv() - lazy (non-infinite)
# TODO - each() methods
# TODO - hash cells with rw, ro, binding hash elements
# TODO - tied hashes
# TODO - delete hash slice
# TODO - %a = %b - whole hash fetch/store
# PIL-Run - %a = { a=>'b', c=>'d' } generates: {({(c, d), (a, b)}, undef)}
# TODO - pick()
# Does pick remove the element? (Hash and Array)
# TODO - (iblech) probably with a warning "uninitialized warning used in numeric contect"
# (Same for hashes: %h{undef} =:= %h{""})
# TODO - is (undef=>undef) a valid Pair?
# fglock PIL-Run currently prints {('undef', undef)}
# buu fglock: For which?
# fglock for { undef=>undef }
# iblech fglock: Right, I'd think so (and this is how I've implemented it in PIL2JS).
# But: By default, hash can autoconvert their keys to Strs, so {undef()=>undef} would have
# the same effect as {""=>undef}. But if a hash is declared with shape(Any), {undef()=>undef}
# should create a hash with .pairs[0].key being undef
# TODO - (for PIL-Run)
# buu iblech: Er, let me rephrase. Why did it print an error message?
# iblech buu: Because {undef,undef} is not a hash, but a Code, and Pugs tried to coerce
# the Code into a Hash, but failed
# buu Er, so how do you create a hash ref?
# iblech buu: \hash(undef,undef), {undef() => undef}, {pair undef, undef}, etc.
# TODO - test - how does a scalar that contains a hash is accessed?
# TODO - test $x := %hash - 'undefine $x'
# TODO - test %hash := $x - error if $x is not bound to a hash
# TODO - tieable hash - cleanup AUTOLOAD
# TODO - test 'readonly'
# Notes:
# * Cell is implemented in the Perl6::Container::Scalar package
use strict;
use Perl6::MetaModel;
use Perl6::Value;
use Perl6::Container::Scalar;
my $class_description = '-0.0.1-cpan:FGLOCK';
class1 'Hash'.$class_description => {
is => [ $::Object ],
class => {
attrs => [],
methods => {}
},
instance => {
attrs => [ [ '$:cell' => {
access => 'rw',
build => sub {
my $cell = Perl6::Cell->new;
my $h = bless {}, 'Perl6::Container::Hash::Object';
$cell->{v} = $h;
$cell->{type} = 'Hash';
return $cell;
} } ] ],
DESTROY => sub {
# _('$:cell' => undef); # XXX - MM2.0 gc workaround
},
methods => {
# %a := %b
'bind' => sub {
my ( $self, $thing ) = @_;
die "argument to Hash bind() must be a Hash"
unless $thing->cell->{type} eq 'Hash';
_('$:cell', $thing->cell);
return $self;
},
'cell' => sub { _('$:cell') }, # cell() is used by bind()
'id' => sub { _('$:cell')->{id} },
'undefine' => sub { _('$:cell')->{v}->clear },
'tieable' => sub { _('$:cell')->{tieable} != 0 },
'tie' => sub { shift; _('$:cell')->tie(@_) },
'untie' => sub { _('$:cell')->untie },
'tied' => sub { _('$:cell')->{tied} },
# See perl5/Perl6-MetaModel/t/14_AUTOLOAD.t
'isa' => sub { ::next_METHOD() },
'does' => sub { ::next_METHOD() },
'ref' => sub { $::CLASS },
'elems' => sub { Int->new( '$.unboxed' =>
_('$:cell')->{tied} ?
_('$:cell')->{tied}->elems :
Perl6::Container::Hash::elems( _('$:cell')->{v} ) )
},
'buckets' => sub { Str->new( '$.unboxed' =>
_('$:cell')->{tied} ?
_('$:cell')->{tied}->buckets :
Perl6::Container::Hash::buckets( _('$:cell')->{v} ) )
},
'pairs' => sub {
my $key = $_[0]->firstkey;
my $ary = Array->new;
while ( defined $key ) {
$ary->push( Pair->new(
'$.key' => $key,
'$.value' => $_[0]->fetch( $key ) ) );
$key = $_[0]->nextkey;
}
return $ary;
},
'kv' => sub {
my $key = $_[0]->firstkey;
my $ary = Array->new;
while ( defined $key ) {
$ary->push( $key, $_[0]->fetch( $key ) );
$key = $_[0]->nextkey;
}
return $ary;
},
'keys' => sub {
my $key = $_[0]->firstkey;
my $ary = Array->new;
while ( defined $key ) {
$ary->push( $key );
$key = $_[0]->nextkey;
}
return $ary;
},
'values' => sub {
my $key = $_[0]->firstkey;
my $ary = Array->new;
while ( defined $key ) {
$ary->push( $_[0]->fetch( $key ) );
$key = $_[0]->nextkey;
}
return $ary;
},
'str' => sub {
my $key = $_[0]->firstkey;
my $value;
my @pairs;
while ( defined $key ) {
$value = $_[0]->fetch( $key );
my $p = Pair->new( '$.key'=>$key, '$.value'=>$value );
push @pairs, $p->str->unboxed;
$key = $_[0]->nextkey;
}
Str->new( '$.unboxed' =>
'{' .
join(', ', @pairs) .
'}'
);
},
'perl' => sub { $_[0]->str },
# TODO - XXX - remove this after implementing hash slice
'postcircumfix:{}' => sub { (shift)->fetch( @_ ) },
'fetch' => sub {
my ($self, @param) = @_;
#warn "FETCH: @param\n";
my $tmp = _('$:cell')->{tied} ? _('$:cell')->{tied} : _('$:cell')->{v};
my $key = shift @param;
if ( Perl6::Value::p6v_isa( $key, 'Array' ) ) {
#warn "Hash slice $key\n";
warn "Infinite hash slice not supported\n"
if Perl6::Value::numify( $key->is_infinite );
#warn "not implemented";
my $a = Array->new();
for ( 0 .. Perl6::Value::numify( $key->elems ) - 1 ) {
my $k = $key->fetch( $_ );
$a->push( $self->fetch( $k ) );
#warn "push $_ - ",Perl6::Value::stringify( $a ),"\n";
#warn "bind $_ -- $k \n";
#$a->fetch( $_ )->bind( $self->fetch( $k ) );
}
#warn $a->fetch( 1 );
#warn $self->fetch( 1 );
#$a->fetch( 1 )->bind( $self->fetch( 1 ) );
return $a->slice( 0 .. Perl6::Value::numify( $a->elems ) - 1 );
}
my $v = $tmp->fetch( $key );
if ( ! Perl6::Value::p6v_isa( $v, 'Scalar' ) ) {
#warn "autovivify - $key - $v\n";
my $s = Scalar->new;
$s->store( $v );
$tmp->store( $key, $s );
return $s;
}
return $v;
},
'store' => sub {
my ($self, @param) = @_;
my $tmp = _('$:cell')->{tied} ? _('$:cell')->{tied} : _('$:cell')->{v};
if ( scalar @param == 1 ) {
# store whole hash
if ( Perl6::Value::p6v_isa( $param[0], 'Hash' ) ) {
$self->clear;
my $key = $param[0]->firstkey;
while ( defined $key ) {
my $tmp = $param[0]->fetch( $key )->fetch;
$self->store( $key, $tmp );
$key = $param[0]->nextkey;
}
return $self;
}
if ( Perl6::Value::p6v_isa( $param[0], 'Array' ) ) {
$self->clear;
for ( 0 .. $param[0]->elems->unboxed - 1 ) {
my $pair = $param[0]->fetch( $_ );
$self->store( $pair->key, $pair->value );
}
return $self;
}
if ( Perl6::Value::p6v_isa( $param[0], 'Pair' ) ) {
$self->clear;
my $pair = $param[0];
$self->store( $pair->key, $pair->value );
return $self;
}
warn "Don't know how to store @param into a Hash";
}
my $key = shift @param;
my $s = $self->fetch( $key );
# fetch should always return Scalar
if ( ! Perl6::Value::p6v_isa( $tmp, 'Scalar' ) ) {
#warn "creating scalar";
$s = Scalar->new;
$tmp->store( $key, $s );
}
$s->store( @param );
return @param;
},
'AUTOLOAD' => sub {
my ($self, @param) = @_;
my $method = __('$AUTOLOAD');
# TODO - add support for tied hash
# TODO - check if scalar := hash works properly
my $tmp = _('$:cell')->{tied} ? _('$:cell')->{tied} : _('$:cell')->{v};
# warn ref($tmp), ' ', $method, " @param == " . $tmp->$method( @param );
return $tmp->$method( @param );
},
},
}
};
# ----- unboxed functions
package Perl6::Container::Hash::Object;
sub store {
my ( $this, $key, $value ) = @_;
$key = $key->fetch if Perl6::Value::p6v_isa( $key, 'Scalar' );
my $s = Perl6::Value::identify( $key );
$this->{$s} = [ $key, $value ];
return $value;
}
sub fetch {
my ( $this, $key ) = @_;
$key = $key->fetch if Perl6::Value::p6v_isa( $key, 'Scalar' );
my $s = Perl6::Value::identify( $key );
$this->{$s}[1];
# warn "fetching " . $this->{$s}[1];
}
sub firstkey {
my ( $this ) = @_;
keys %$this; # force reset the iterator
my $s = each %$this;
return unless defined $s;
$this->{$s}[0];
}
sub nextkey {
my ( $this, $key ) = @_;
my $s = each %$this;
return unless defined $s;
$this->{$s}[0];
}
sub exists {
my ( $this, $key ) = @_;
$key = $key->fetch if Perl6::Value::p6v_isa( $key, 'Scalar' );
my $s = Perl6::Value::identify( $key );
exists $this->{$s};
}
sub delete {
my ( $this, $key ) = @_;
$key = $key->fetch if Perl6::Value::p6v_isa( $key, 'Scalar' );
my $s = Perl6::Value::identify( $key );
my $r = delete $this->{$s};
$r->[1];
}
sub clear {
my ( $this ) = @_;
%$this = ();
}
sub scalar {
my ( $this ) = @_;
0 + %$this;
}
package Perl6::Container::Hash::Native;
sub new {
my $class = shift;
# hashref => \%ENV;
my %param = @_;
$param{hashref} = {} unless defined $param{hashref};
bless { %param }, $class;
}
sub store {
my ( $this, $key, $value ) = @_;
my $s = Perl6::Value::identify( $key );
my $v;
$v = $value->unboxed if ref( $value );
no warnings 'uninitialized';
$this->{hashref}{$s} = $v;
return $value;
}
sub fetch {
my ( $this, $key ) = @_;
my $s = Perl6::Value::identify( $key );
$this->{hashref}{$s}
# warn "fetching " . $this->{$s}[1];
}
sub firstkey {
my ( $this ) = @_;
keys %{$this->{hashref}}; # force reset the iterator
each %{$this->{hashref}};
}
sub nextkey {
my ( $this, $key ) = @_;
each %{$this->{hashref}};
}
sub exists {
my ( $this, $key ) = @_;
my $s = Perl6::Value::identify( $key );
exists $this->{hashref}{$s};
}
sub delete {
my ( $this, $key ) = @_;
my $s = Perl6::Value::identify( $key );
my $r = delete $this->{hashref}{$s};
}
sub clear {
my ( $this ) = @_;
%{$this->{hashref}} = ();
}
sub scalar {
my ( $this ) = @_;
0 + %{$this->{hashref}};
}
package Perl6::Container::Hash;
sub clone {
my $tmp = { %{ $_[0] } };
$tmp;
}
sub elems {
my @tmp = %{ $_[0] };
@tmp / 2
}
sub buckets { scalar %{ $_[0] } }
1;
__END__
=head1 NAME
Perl6::Container::Hash - Perl extension for Perl6 "Hash" class
=head1 SYNOPSIS
use Perl6::Container::Hash;
...
=head1 DESCRIPTION
...
=head1 SEE ALSO
Pugs
=head1 AUTHOR
Flavio S. Glock, E<lt>fglock@gmail.com<gt>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2005 by Flavio S. Glock
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.4 or,
at your option, any later version of Perl 5 you may have available.
=cut