1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
|
# This code is part of Perl distribution Hash-Case version 1.07.
# The POD got stripped from this file by OODoc version 3.06.
# For contributors see file ChangeLog.
# This software is copyright (c) 2002-2026 by Mark Overmeer.
# This is free software; you can redistribute it and/or modify it under
# the same terms as the Perl 5 programming language system itself.
# SPDX-License-Identifier: Artistic-1.0-Perl OR GPL-1.0-or-later
package Hash::Case::Preserve;{
our $VERSION = '1.07';
}
use base 'Hash::Case';
use strict;
use warnings;
use Carp 'croak';
#--------------------
sub init($)
{ my ($self, $args) = @_;
$self->{HCP_data} = {};
$self->{HCP_keys} = {};
my $keep = $args->{keep} || 'LAST';
if($keep eq 'LAST') { $self->{HCP_update} = 1 }
elsif($keep eq 'FIRST') { $self->{HCP_update} = 0 }
else
{ croak "use 'FIRST' or 'LAST' with the option keep";
}
$self->SUPER::native_init($args);
}
# Maintain two hashes within this object: one to store the values, and
# one to preserve the casing. The main object also stores the options.
# The data is kept under lower cased keys.
sub FETCH($) { $_[0]->{HCP_data}{lc $_[1]} }
sub STORE($$)
{ my ($self, $key, $value) = @_;
my $lckey = lc $key;
$self->{HCP_keys}{$lckey} = $key
if $self->{HCP_update} || !exists $self->{HCP_keys}{$lckey};
$self->{HCP_data}{$lckey} = $value;
}
sub FIRSTKEY
{ my $self = shift;
my $a = scalar keys %{$self->{HCP_keys}};
$self->NEXTKEY;
}
sub NEXTKEY($)
{ my $self = shift;
if(my ($k, $v) = each %{$self->{HCP_keys}})
{ return wantarray ? ($v, $self->{HCP_data}{$k}) : $v;
}
();
}
sub EXISTS($) { exists $_[0]->{HCP_data}{lc $_[1]} }
sub DELETE($)
{ my $lckey = lc $_[1];
delete $_[0]->{HCP_keys}{$lckey};
delete $_[0]->{HCP_data}{$lckey};
}
sub CLEAR()
{ %{$_[0]->{HCP_data}} = ();
%{$_[0]->{HCP_keys}} = ();
}
1;
|
