File | /usr/share/perl/5.10/Tie/Hash.pm |
Statements Executed | 9 |
Total Time | 0.0009169 seconds |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
0 | 0 | 0 | 0s | 0s | CLEAR | Tie::ExtraHash::
0 | 0 | 0 | 0s | 0s | DELETE | Tie::ExtraHash::
0 | 0 | 0 | 0s | 0s | EXISTS | Tie::ExtraHash::
0 | 0 | 0 | 0s | 0s | FETCH | Tie::ExtraHash::
0 | 0 | 0 | 0s | 0s | FIRSTKEY | Tie::ExtraHash::
0 | 0 | 0 | 0s | 0s | NEXTKEY | Tie::ExtraHash::
0 | 0 | 0 | 0s | 0s | SCALAR | Tie::ExtraHash::
0 | 0 | 0 | 0s | 0s | STORE | Tie::ExtraHash::
0 | 0 | 0 | 0s | 0s | TIEHASH | Tie::ExtraHash::
0 | 0 | 0 | 0s | 0s | BEGIN | Tie::Hash::
0 | 0 | 0 | 0s | 0s | CLEAR | Tie::Hash::
0 | 0 | 0 | 0s | 0s | EXISTS | Tie::Hash::
0 | 0 | 0 | 0s | 0s | TIEHASH | Tie::Hash::
0 | 0 | 0 | 0s | 0s | new | Tie::Hash::
0 | 0 | 0 | 0s | 0s | CLEAR | Tie::StdHash::
0 | 0 | 0 | 0s | 0s | DELETE | Tie::StdHash::
0 | 0 | 0 | 0s | 0s | EXISTS | Tie::StdHash::
0 | 0 | 0 | 0s | 0s | FETCH | Tie::StdHash::
0 | 0 | 0 | 0s | 0s | FIRSTKEY | Tie::StdHash::
0 | 0 | 0 | 0s | 0s | NEXTKEY | Tie::StdHash::
0 | 0 | 0 | 0s | 0s | SCALAR | Tie::StdHash::
0 | 0 | 0 | 0s | 0s | STORE | Tie::StdHash::
0 | 0 | 0 | 0s | 0s | TIEHASH | Tie::StdHash::
Line | Stmts. | Exclusive Time | Avg. | Code |
---|---|---|---|---|
1 | package Tie::Hash; | |||
2 | ||||
3 | 1 | 800ns | 800ns | our $VERSION = '1.02'; |
4 | ||||
5 | 3 | 60µs | 20µs | use Carp; # spent 92µs making 1 call to Exporter::import |
6 | 3 | 842µs | 280µs | use warnings::register; # spent 118µs making 1 call to warnings::register::import |
7 | ||||
8 | sub new { | |||
9 | my $pkg = shift; | |||
10 | $pkg->TIEHASH(@_); | |||
11 | } | |||
12 | ||||
13 | # Grandfather "new" | |||
14 | ||||
15 | sub TIEHASH { | |||
16 | my $pkg = shift; | |||
17 | if (defined &{"${pkg}::new"}) { | |||
18 | warnings::warnif("WARNING: calling ${pkg}->new since ${pkg}->TIEHASH is missing"); | |||
19 | $pkg->new(@_); | |||
20 | } | |||
21 | else { | |||
22 | croak "$pkg doesn't define a TIEHASH method"; | |||
23 | } | |||
24 | } | |||
25 | ||||
26 | sub EXISTS { | |||
27 | my $pkg = ref $_[0]; | |||
28 | croak "$pkg doesn't define an EXISTS method"; | |||
29 | } | |||
30 | ||||
31 | sub CLEAR { | |||
32 | my $self = shift; | |||
33 | my $key = $self->FIRSTKEY(@_); | |||
34 | my @keys; | |||
35 | ||||
36 | while (defined $key) { | |||
37 | push @keys, $key; | |||
38 | $key = $self->NEXTKEY(@_, $key); | |||
39 | } | |||
40 | foreach $key (@keys) { | |||
41 | $self->DELETE(@_, $key); | |||
42 | } | |||
43 | } | |||
44 | ||||
45 | # The Tie::StdHash package implements standard perl hash behaviour. | |||
46 | # It exists to act as a base class for classes which only wish to | |||
47 | # alter some parts of their behaviour. | |||
48 | ||||
49 | package Tie::StdHash; | |||
50 | # @ISA = qw(Tie::Hash); # would inherit new() only | |||
51 | ||||
52 | 1 | 6µs | 6µs | sub TIEHASH { bless {}, $_[0] } |
53 | sub STORE { $_[0]->{$_[1]} = $_[2] } | |||
54 | sub FETCH { $_[0]->{$_[1]} } | |||
55 | sub FIRSTKEY { my $a = scalar keys %{$_[0]}; each %{$_[0]} } | |||
56 | sub NEXTKEY { each %{$_[0]} } | |||
57 | sub EXISTS { exists $_[0]->{$_[1]} } | |||
58 | sub DELETE { delete $_[0]->{$_[1]} } | |||
59 | sub CLEAR { %{$_[0]} = () } | |||
60 | sub SCALAR { scalar %{$_[0]} } | |||
61 | ||||
62 | package Tie::ExtraHash; | |||
63 | ||||
64 | sub TIEHASH { my $p = shift; bless [{}, @_], $p } | |||
65 | sub STORE { $_[0][0]{$_[1]} = $_[2] } | |||
66 | sub FETCH { $_[0][0]{$_[1]} } | |||
67 | sub FIRSTKEY { my $a = scalar keys %{$_[0][0]}; each %{$_[0][0]} } | |||
68 | sub NEXTKEY { each %{$_[0][0]} } | |||
69 | sub EXISTS { exists $_[0][0]->{$_[1]} } | |||
70 | sub DELETE { delete $_[0][0]->{$_[1]} } | |||
71 | sub CLEAR { %{$_[0][0]} = () } | |||
72 | sub SCALAR { scalar %{$_[0][0]} } | |||
73 | ||||
74 | 1 | 8µs | 8µs | 1; |