File Coverage

File:	Dpkg/Control/HashCore/Tie.pm
Coverage:	91.9%

line	stmt	bran	cond	sub	pod	time	code
1							# Copyright Â© 2007-2009 RaphaÃ«l Hertzog <hertzog@debian.org>
2							# Copyright Â© 2009, 2012-2019, 2021 Guillem Jover <guillem@debian.org>
3							#
4							# This program is free software; you can redistribute it and/or modify
5							# it under the terms of the GNU General Public License as published by
6							# the Free Software Foundation; either version 2 of the License, or
7							# (at your option) any later version.
8							#
9							# This program is distributed in the hope that it will be useful,
10							# but WITHOUT ANY WARRANTY; without even the implied warranty of
11							# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12							# GNU General Public License for more details.
13							#
14							# You should have received a copy of the GNU General Public License
15							# along with this program. If not, see <https://www.gnu.org/licenses/>.
16
17							=encoding utf8
18
19 - 35							=head1 NAME Dpkg::Control::HashCore::Tie - ties a Dpkg::Control::Hash object =head1 DESCRIPTION This module provides a class that is used to tie a hash. It implements hash-like functions by normalizing the name of fields received in keys (using Dpkg::Control::Fields::field_capitalize()). It also stores the order in which fields have been added in order to be able to dump them in the same order. But the order information is stored in a parent object of type L<Dpkg::Control>. B<Note>: This is a private module, its API can change at any time. =cut
36
37							package Dpkg::Control::HashCore::Tie 0.01;
38
39	138 138 138			138		495 135 2199	use strict;
40	138 138 138			138		454 151 3265	use warnings;
41
42	138 138 138			138		262 105 6302	use Dpkg::Control::FieldsCore;
43
44	138 138 138			138		291 94 3298	use Carp;
45	138 138 138			138		272 104 3100	use Tie::Hash;
46	138 138 138			138		313 111 486	use parent -norequire, qw(Tie::ExtraHash);
47
48							# $self->[0] is the real hash
49							# $self->[1] is a reference to the hash contained by the parent object.
50							# This reference bypasses the top-level scalar reference of a
51							# Dpkg::Control::Hash, hence ensuring that reference gets DESTROYed
52							# properly.
53
54 - 63							=head1 FUNCTIONS =over 4 =item Dpkg::Control::Hash->new($parent) Return a reference to a tied hash implementing storage of simple "field: value" mapping as used in many Debian-specific files. =cut
64
65							sub new {
66	2676			2676	1	2664	my ($class, @args) = @_;
67	2676					2013	my $hash = {};
68
69	2676 2676					1728 4365	tie %{$hash}, $class, @args; ## no critic (Miscellanea::ProhibitTies)
70	2676					4442	return $hash;
71							}
72
73							sub TIEHASH {
74	2676			2676		2486	my ($class, $parent) = @_;
75
76	2676	0	33			5613	croak 'parent object must be Dpkg::Control::Hash'
77							if not $parent->isa('Dpkg::Control::HashCore') and
78							not $parent->isa('Dpkg::Control::Hash');
79	2676					7610	return bless [ {}, $$parent ], $class;
80							}
81
82							sub FETCH {
83	14169			14169		10838	my ($self, $key) = @_;
84
85	14169					9193	$key = lc($key);
86	14169	100				33432	return $self->[0]->{$key} if exists $self->[0]->{$key};
87	39					78	return;
88							}
89
90							sub STORE {
91	19101			19101		19715	my ($self, $key, $value) = @_;
92
93	19101					12238	$key = lc($key);
94	19101	100				18165	if (not exists $self->[0]->{$key}) {
95	15030 15030					8381 15595	push @{$self->[1]->{in_order}}, field_capitalize($key);
96							}
97	19101					26572	$self->[0]->{$key} = $value;
98							}
99
100							sub EXISTS {
101	7383			7383		5801	my ($self, $key) = @_;
102
103	7383					5074	$key = lc($key);
104	7383					12315	return exists $self->[0]->{$key};
105							}
106
107							sub DELETE {
108	3			3		7	my ($self, $key) = @_;
109	3					8	my $parent = $self->[1];
110	3					5	my $in_order = $parent->{in_order};
111
112	3					4	$key = lc($key);
113	3	50				6	if (exists $self->[0]->{$key}) {
114	3					3	delete $self->[0]->{$key};
115	3 3 9 3					3 3 175 4	@{$in_order} = grep { lc ne $key } @{$in_order};
116	3					266	return 1;
117							} else {
118	0					0	return 0;
119							}
120							}
121
122							sub FIRSTKEY {
123	2292			2292		1559	my $self = shift;
124	2292					1699	my $parent = $self->[1];
125
126	2292 2292					1424 2566	foreach my $key (@{$parent->{in_order}}) {
127	2292	50				5190	return $key if exists $self->[0]->{lc $key};
128							}
129							}
130
131							sub NEXTKEY {
132	4239			4239		3283	my ($self, $prev) = @_;
133	4239					2595	my $parent = $self->[1];
134	4239					2466	my $found = 0;
135
136	4239 4239					2451 3334	foreach my $key (@{$parent->{in_order}}) {
137	9210	100				6236	if ($found) {
138	1947	50				3794	return $key if exists $self->[0]->{lc $key};
139							} else {
140	7263	100				6760	$found = 1 if $key eq $prev;
141							}
142							}
143	2292					2956	return;
144							}
145
146							=back
147
148 - 154							=head1 CHANGES =head2 Version 0.xx This is a private module. =cut
155
156							1;