line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package File::KDBX::Object; |
2
|
|
|
|
|
|
|
# ABSTRACT: A KDBX database object |
3
|
|
|
|
|
|
|
|
4
|
11
|
|
|
11
|
|
6890
|
use warnings; |
|
11
|
|
|
|
|
24
|
|
|
11
|
|
|
|
|
354
|
|
5
|
11
|
|
|
11
|
|
50
|
use strict; |
|
11
|
|
|
|
|
21
|
|
|
11
|
|
|
|
|
215
|
|
6
|
|
|
|
|
|
|
|
7
|
11
|
|
|
11
|
|
47
|
use Devel::GlobalDestruction; |
|
11
|
|
|
|
|
18
|
|
|
11
|
|
|
|
|
65
|
|
8
|
11
|
|
|
11
|
|
651
|
use File::KDBX::Constants qw(:bool); |
|
11
|
|
|
|
|
19
|
|
|
11
|
|
|
|
|
1375
|
|
9
|
11
|
|
|
11
|
|
70
|
use File::KDBX::Error; |
|
11
|
|
|
|
|
17
|
|
|
11
|
|
|
|
|
436
|
|
10
|
11
|
|
|
11
|
|
56
|
use File::KDBX::Util qw(:uuid); |
|
11
|
|
|
|
|
18
|
|
|
11
|
|
|
|
|
940
|
|
11
|
11
|
|
|
11
|
|
107
|
use Hash::Util::FieldHash qw(fieldhashes); |
|
11
|
|
|
|
|
16
|
|
|
11
|
|
|
|
|
518
|
|
12
|
11
|
|
|
11
|
|
59
|
use List::Util qw(any first); |
|
11
|
|
|
|
|
17
|
|
|
11
|
|
|
|
|
597
|
|
13
|
11
|
|
|
11
|
|
58
|
use Ref::Util qw(is_arrayref is_plain_arrayref is_plain_hashref is_ref); |
|
11
|
|
|
|
|
27
|
|
|
11
|
|
|
|
|
526
|
|
14
|
11
|
|
|
11
|
|
65
|
use Scalar::Util qw(blessed weaken); |
|
11
|
|
|
|
|
25
|
|
|
11
|
|
|
|
|
450
|
|
15
|
11
|
|
|
11
|
|
58
|
use namespace::clean; |
|
11
|
|
|
|
|
17
|
|
|
11
|
|
|
|
|
61
|
|
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
our $VERSION = '0.904'; # VERSION |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
fieldhashes \my (%KDBX, %PARENT, %TXNS, %REFS, %SIGNALS); |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
|
22
|
|
|
|
|
|
|
sub new { |
23
|
237
|
|
|
237
|
1
|
97656
|
my $class = shift; |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
# copy constructor |
26
|
237
|
50
|
100
|
|
|
736
|
return $_[0]->clone if @_ == 1 && blessed $_[0] && $_[0]->isa($class); |
|
|
|
66
|
|
|
|
|
27
|
|
|
|
|
|
|
|
28
|
237
|
|
|
|
|
319
|
my $data; |
29
|
237
|
100
|
|
|
|
669
|
$data = shift if is_plain_hashref($_[0]); |
30
|
|
|
|
|
|
|
|
31
|
237
|
|
|
|
|
306
|
my $kdbx; |
32
|
237
|
100
|
|
|
|
526
|
$kdbx = shift if @_ % 2 == 1; |
33
|
|
|
|
|
|
|
|
34
|
237
|
|
|
|
|
606
|
my %args = @_; |
35
|
237
|
100
|
33
|
|
|
784
|
$args{kdbx} //= $kdbx if defined $kdbx; |
36
|
|
|
|
|
|
|
|
37
|
237
|
|
100
|
|
|
760
|
my $self = bless $data // {}, $class; |
38
|
237
|
|
|
|
|
1001
|
$self->init(%args); |
39
|
237
|
100
|
|
|
|
823
|
$self->_set_nonlazy_attributes if !$data; |
40
|
237
|
|
|
|
|
5473
|
return $self; |
41
|
|
|
|
|
|
|
} |
42
|
|
|
|
|
|
|
|
43
|
0
|
|
|
0
|
|
0
|
sub _set_nonlazy_attributes { die 'Not implemented' } |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
sub init { |
47
|
133
|
|
|
133
|
1
|
180
|
my $self = shift; |
48
|
133
|
|
|
|
|
327
|
my %args = @_; |
49
|
|
|
|
|
|
|
|
50
|
133
|
|
|
|
|
454
|
while (my ($key, $val) = each %args) { |
51
|
331
|
50
|
|
|
|
1355
|
if (my $method = $self->can($key)) { |
52
|
331
|
|
|
|
|
1164
|
$self->$method($val); |
53
|
|
|
|
|
|
|
} |
54
|
|
|
|
|
|
|
} |
55
|
|
|
|
|
|
|
|
56
|
133
|
|
|
|
|
339
|
return $self; |
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
sub wrap { |
61
|
798
|
|
|
798
|
1
|
1169
|
my $class = shift; |
62
|
798
|
|
|
|
|
1048
|
my $object = shift; |
63
|
798
|
100
|
66
|
|
|
5204
|
return $object if blessed $object && $object->isa($class); |
64
|
114
|
100
|
|
|
|
333
|
return $class->new(@_, @$object) if is_arrayref($object); |
65
|
72
|
|
|
|
|
277
|
return $class->new($object, @_); |
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
|
69
|
0
|
|
|
0
|
1
|
0
|
sub label { die 'Not implemented' } |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
|
72
|
|
|
|
|
|
|
my %CLONE = (entries => 1, groups => 1, history => 1); |
73
|
|
|
|
|
|
|
sub clone { |
74
|
31
|
|
|
31
|
1
|
62
|
my $self = shift; |
75
|
31
|
|
|
|
|
80
|
my %args = @_; |
76
|
|
|
|
|
|
|
|
77
|
31
|
|
100
|
|
|
159
|
local $CLONE{new_uuid} = $args{new_uuid} // $args{parent} // 0; |
|
|
|
100
|
|
|
|
|
78
|
31
|
|
100
|
|
|
92
|
local $CLONE{entries} = $args{entries} // 1; |
79
|
31
|
|
100
|
|
|
76
|
local $CLONE{groups} = $args{groups} // 1; |
80
|
31
|
|
100
|
|
|
69
|
local $CLONE{history} = $args{history} // 1; |
81
|
31
|
|
50
|
|
|
81
|
local $CLONE{reference_password} = $args{reference_password} // 0; |
82
|
31
|
|
100
|
|
|
79
|
local $CLONE{reference_username} = $args{reference_username} // 0; |
83
|
|
|
|
|
|
|
|
84
|
31
|
|
|
|
|
126
|
require Storable; |
85
|
31
|
|
|
|
|
467
|
my $copy = Storable::dclone($self); |
86
|
|
|
|
|
|
|
|
87
|
31
|
100
|
66
|
|
|
101
|
if ($args{relabel} and my $label = $self->label) { |
88
|
3
|
|
|
|
|
12
|
$copy->label("$label - Copy"); |
89
|
|
|
|
|
|
|
} |
90
|
31
|
100
|
66
|
|
|
79
|
if ($args{parent} and my $parent = $self->group) { |
91
|
3
|
|
|
|
|
12
|
$parent->add_object($copy); |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
|
94
|
31
|
|
|
|
|
342
|
return $copy; |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
sub STORABLE_freeze { |
98
|
64
|
|
|
64
|
0
|
126
|
my $self = shift; |
99
|
64
|
|
|
|
|
79
|
my $cloning = shift; |
100
|
|
|
|
|
|
|
|
101
|
64
|
|
|
|
|
567
|
my $copy = {%$self}; |
102
|
64
|
100
|
|
|
|
190
|
delete $copy->{entries} if !$CLONE{entries}; |
103
|
64
|
100
|
|
|
|
119
|
delete $copy->{groups} if !$CLONE{groups}; |
104
|
64
|
100
|
|
|
|
105
|
delete $copy->{history} if !$CLONE{history}; |
105
|
|
|
|
|
|
|
|
106
|
64
|
50
|
|
|
|
4006
|
return ($cloning ? Hash::Util::FieldHash::id($self) : ''), $copy; |
107
|
|
|
|
|
|
|
} |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
sub STORABLE_thaw { |
110
|
64
|
|
|
64
|
0
|
136
|
my $self = shift; |
111
|
64
|
|
|
|
|
80
|
my $cloning = shift; |
112
|
64
|
|
|
|
|
88
|
my $addr = shift; |
113
|
64
|
|
|
|
|
74
|
my $copy = shift; |
114
|
|
|
|
|
|
|
|
115
|
64
|
|
|
|
|
478
|
@$self{keys %$copy} = values %$copy; |
116
|
|
|
|
|
|
|
|
117
|
64
|
50
|
|
|
|
179
|
if ($cloning) { |
118
|
64
|
|
|
|
|
183
|
my $kdbx = $KDBX{$addr}; |
119
|
64
|
100
|
|
|
|
147
|
$self->kdbx($kdbx) if $kdbx; |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
|
122
|
64
|
50
|
|
|
|
124
|
if (defined $self->{uuid}) { |
123
|
64
|
100
|
66
|
|
|
241
|
if (($CLONE{reference_password} || $CLONE{reference_username}) && $self->can('strings')) { |
|
|
|
66
|
|
|
|
|
124
|
2
|
|
|
|
|
7
|
my $uuid = format_uuid($self->{uuid}); |
125
|
2
|
|
|
|
|
5
|
my $clone_obj = do { |
126
|
2
|
|
|
|
|
3
|
local $CLONE{new_uuid} = 0; |
127
|
2
|
|
|
|
|
4
|
local $CLONE{entries} = 1; |
128
|
2
|
|
|
|
|
5
|
local $CLONE{groups} = 1; |
129
|
2
|
|
|
|
|
3
|
local $CLONE{history} = 1; |
130
|
2
|
|
|
|
|
3
|
local $CLONE{reference_password} = 0; |
131
|
2
|
|
|
|
|
4
|
local $CLONE{reference_username} = 0; |
132
|
|
|
|
|
|
|
# Clone only the entry's data and manually bless to avoid infinite recursion. |
133
|
2
|
|
|
|
|
95
|
bless Storable::dclone({%$copy}), 'File::KDBX::Entry'; |
134
|
|
|
|
|
|
|
}; |
135
|
2
|
|
|
|
|
9
|
my $txn = $self->begin_work(snapshot => $clone_obj); |
136
|
2
|
50
|
|
|
|
6
|
if ($CLONE{reference_password}) { |
137
|
0
|
|
|
|
|
0
|
$self->password("{REF:P\@I:$uuid}"); |
138
|
|
|
|
|
|
|
} |
139
|
2
|
50
|
|
|
|
4
|
if ($CLONE{reference_username}) { |
140
|
2
|
|
|
|
|
12
|
$self->username("{REF:U\@I:$uuid}"); |
141
|
|
|
|
|
|
|
} |
142
|
2
|
|
|
|
|
6
|
$txn->commit; |
143
|
|
|
|
|
|
|
} |
144
|
64
|
100
|
|
|
|
127
|
$self->uuid(generate_uuid) if $CLONE{new_uuid}; |
145
|
|
|
|
|
|
|
} |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
# Dualvars aren't cloned as dualvars, so dualify the icon. |
148
|
64
|
50
|
|
|
|
224
|
$self->icon_id($self->{icon_id}) if defined $self->{icon_id}; |
149
|
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
sub kdbx { |
153
|
978
|
|
|
978
|
1
|
4937
|
my $self = shift; |
154
|
978
|
50
|
|
|
|
1753
|
$self = $self->new if !ref $self; |
155
|
978
|
100
|
|
|
|
1749
|
if (@_) { |
156
|
310
|
50
|
|
|
|
591
|
if (my $kdbx = shift) { |
157
|
310
|
|
|
|
|
1668
|
$KDBX{$self} = $kdbx; |
158
|
310
|
|
|
|
|
881
|
weaken $KDBX{$self}; |
159
|
|
|
|
|
|
|
} |
160
|
|
|
|
|
|
|
else { |
161
|
0
|
|
|
|
|
0
|
delete $KDBX{$self}; |
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
} |
164
|
978
|
100
|
|
|
|
3538
|
$KDBX{$self} or throw 'Object is disconnected', object => $self; |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
|
168
|
|
|
|
|
|
|
sub is_connected { |
169
|
84
|
|
|
84
|
1
|
125
|
my $self = shift; |
170
|
84
|
|
|
|
|
119
|
return !!eval { $self->kdbx }; |
|
84
|
|
|
|
|
166
|
|
171
|
|
|
|
|
|
|
} |
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
|
174
|
5
|
|
|
5
|
1
|
39
|
sub id { format_uuid(shift->uuid, @_) } |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
sub group { |
178
|
154
|
|
|
154
|
1
|
204
|
my $self = shift; |
179
|
|
|
|
|
|
|
|
180
|
154
|
100
|
|
|
|
309
|
if (my $new_group = shift) { |
181
|
1
|
|
|
|
|
5
|
my $old_group = $self->group; |
182
|
1
|
50
|
|
|
|
6
|
return $new_group if Hash::Util::FieldHash::id($old_group) == Hash::Util::FieldHash::id($new_group); |
183
|
|
|
|
|
|
|
# move to a new parent |
184
|
1
|
50
|
|
|
|
6
|
$self->remove(signal => 0) if $old_group; |
185
|
1
|
|
|
|
|
5
|
$self->location_changed('now'); |
186
|
1
|
|
|
|
|
16
|
$new_group->add_object($self); |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
|
189
|
154
|
|
|
|
|
290
|
my $id = Hash::Util::FieldHash::id($self); |
190
|
154
|
100
|
|
|
|
337
|
if (my $group = $PARENT{$self}) { |
191
|
31
|
|
|
|
|
70
|
my $method = $self->_parent_container; |
192
|
31
|
50
|
|
31
|
|
86
|
return $group if first { $id == Hash::Util::FieldHash::id($_) } @{$group->$method}; |
|
31
|
|
|
|
|
154
|
|
|
31
|
|
|
|
|
82
|
|
193
|
0
|
|
|
|
|
0
|
delete $PARENT{$self}; |
194
|
|
|
|
|
|
|
} |
195
|
|
|
|
|
|
|
# always get lineage from root to leaf because the other way requires parent, so it would be recursive |
196
|
123
|
100
|
|
|
|
210
|
my $lineage = $self->kdbx->_trace_lineage($self) or return; |
197
|
1
|
50
|
|
|
|
4
|
my $group = pop @$lineage or return; |
198
|
1
|
|
|
|
|
5
|
$PARENT{$self} = $group; weaken $PARENT{$self}; |
|
1
|
|
|
|
|
4
|
|
199
|
1
|
|
|
|
|
3
|
return $group; |
200
|
|
|
|
|
|
|
} |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
sub _set_group { |
203
|
110
|
|
|
110
|
|
143
|
my $self = shift; |
204
|
110
|
100
|
|
|
|
188
|
if (my $parent = shift) { |
205
|
48
|
|
|
|
|
448
|
$PARENT{$self} = $parent; |
206
|
48
|
|
|
|
|
139
|
weaken $PARENT{$self}; |
207
|
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
|
else { |
209
|
62
|
|
|
|
|
181
|
delete $PARENT{$self}; |
210
|
|
|
|
|
|
|
} |
211
|
110
|
|
|
|
|
221
|
return $self; |
212
|
|
|
|
|
|
|
} |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
### Name of the parent attribute expected to contain the object |
215
|
0
|
|
|
0
|
|
0
|
sub _parent_container { die 'Not implemented' } |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
sub lineage { |
219
|
5
|
|
|
5
|
1
|
8
|
my $self = shift; |
220
|
5
|
|
|
|
|
8
|
my $base = shift; |
221
|
|
|
|
|
|
|
|
222
|
5
|
50
|
|
|
|
12
|
my $base_addr = $base ? Hash::Util::FieldHash::id($base) : 0; |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
# try leaf to root |
225
|
5
|
|
|
|
|
7
|
my @path; |
226
|
5
|
|
|
|
|
7
|
my $object = $self; |
227
|
5
|
|
|
|
|
12
|
while ($object = $object->group) { |
228
|
8
|
|
|
|
|
16
|
unshift @path, $object; |
229
|
8
|
50
|
|
|
|
21
|
last if $base_addr == Hash::Util::FieldHash::id($object); |
230
|
|
|
|
|
|
|
} |
231
|
5
|
50
|
33
|
|
|
32
|
return \@path if @path && ($base_addr == Hash::Util::FieldHash::id($path[0]) || $path[0]->is_root); |
|
|
|
33
|
|
|
|
|
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
# try root to leaf |
234
|
0
|
|
|
|
|
0
|
return $self->kdbx->_trace_lineage($self, $base); |
235
|
|
|
|
|
|
|
} |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
sub remove { |
239
|
55
|
|
|
55
|
1
|
78
|
my $self = shift; |
240
|
55
|
|
|
|
|
174
|
my $parent = $self->group; |
241
|
55
|
100
|
|
|
|
139
|
$parent->remove_object($self, @_) if $parent; |
242
|
55
|
|
|
|
|
197
|
$self->_set_group(undef); |
243
|
55
|
|
|
|
|
115
|
return $self; |
244
|
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
sub recycle { |
248
|
1
|
|
|
1
|
1
|
3
|
my $self = shift; |
249
|
1
|
|
|
|
|
3
|
return $self->group($self->kdbx->recycle_bin); |
250
|
|
|
|
|
|
|
} |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
sub recycle_or_remove { |
254
|
3
|
|
|
3
|
1
|
23
|
my $self = shift; |
255
|
3
|
|
|
|
|
4
|
my $kdbx = eval { $self->kdbx }; |
|
3
|
|
|
|
|
7
|
|
256
|
3
|
100
|
66
|
|
|
14
|
if ($kdbx && $kdbx->recycle_bin_enabled && !$self->is_recycled) { |
|
|
|
100
|
|
|
|
|
257
|
1
|
|
|
|
|
6
|
$self->recycle; |
258
|
|
|
|
|
|
|
} |
259
|
|
|
|
|
|
|
else { |
260
|
2
|
|
|
|
|
23
|
$self->remove; |
261
|
|
|
|
|
|
|
} |
262
|
|
|
|
|
|
|
} |
263
|
|
|
|
|
|
|
|
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
sub is_recycled { |
266
|
4
|
|
|
4
|
1
|
41
|
my $self = shift; |
267
|
4
|
50
|
|
|
|
6
|
eval { $self->kdbx } or return FALSE; |
|
4
|
|
|
|
|
6
|
|
268
|
4
|
|
100
|
5
|
|
9
|
return !!($self->group && any { $_->is_recycle_bin } @{$self->lineage}); |
|
5
|
|
|
|
|
14
|
|
269
|
|
|
|
|
|
|
} |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
############################################################################## |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
sub tag_list { |
275
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
276
|
0
|
|
0
|
|
|
0
|
return grep { $_ ne '' } split(/[,\.:;]|\s+/, trim($self->tags) // ''); |
|
0
|
|
|
|
|
0
|
|
277
|
|
|
|
|
|
|
} |
278
|
|
|
|
|
|
|
|
279
|
|
|
|
|
|
|
|
280
|
|
|
|
|
|
|
sub custom_icon { |
281
|
7
|
|
|
7
|
1
|
16
|
my $self = shift; |
282
|
7
|
|
|
|
|
26
|
my $kdbx = $self->kdbx; |
283
|
7
|
100
|
|
|
|
16
|
if (@_) { |
284
|
4
|
|
|
|
|
9
|
my $img = shift; |
285
|
4
|
100
|
|
|
|
15
|
my $uuid = defined $img ? $kdbx->add_custom_icon($img, @_) : undef; |
286
|
4
|
100
|
|
|
|
16
|
$self->icon_id(0) if $uuid; |
287
|
4
|
|
|
|
|
11
|
$self->custom_icon_uuid($uuid); |
288
|
4
|
|
|
|
|
11
|
return $img; |
289
|
|
|
|
|
|
|
} |
290
|
3
|
|
|
|
|
10
|
return $kdbx->custom_icon_data($self->custom_icon_uuid); |
291
|
|
|
|
|
|
|
} |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
sub custom_data { |
295
|
517
|
|
|
517
|
1
|
751
|
my $self = shift; |
296
|
517
|
50
|
66
|
|
|
1089
|
$self->{custom_data} = shift if @_ == 1 && is_plain_hashref($_[0]); |
297
|
517
|
100
|
100
|
|
|
2505
|
return $self->{custom_data} //= {} if !@_; |
298
|
|
|
|
|
|
|
|
299
|
19
|
100
|
|
|
|
90
|
my %args = @_ == 2 ? (key => shift, value => shift) |
|
|
100
|
|
|
|
|
|
300
|
|
|
|
|
|
|
: @_ % 2 == 1 ? (key => shift, @_) : @_; |
301
|
|
|
|
|
|
|
|
302
|
19
|
50
|
66
|
|
|
53
|
if (!$args{key} && !$args{value}) { |
303
|
2
|
|
|
|
|
9
|
my %standard = (key => 1, value => 1, last_modification_time => 1); |
304
|
2
|
|
|
|
|
6
|
my @other_keys = grep { !$standard{$_} } keys %args; |
|
4
|
|
|
|
|
13
|
|
305
|
2
|
50
|
|
|
|
7
|
if (@other_keys == 1) { |
306
|
2
|
|
|
|
|
4
|
my $key = $args{key} = $other_keys[0]; |
307
|
2
|
|
|
|
|
6
|
$args{value} = delete $args{$key}; |
308
|
|
|
|
|
|
|
} |
309
|
|
|
|
|
|
|
} |
310
|
|
|
|
|
|
|
|
311
|
19
|
50
|
|
|
|
43
|
my $key = $args{key} or throw 'Must provide a custom_data key to access'; |
312
|
|
|
|
|
|
|
|
313
|
19
|
50
|
|
|
|
53
|
return $self->{custom_data}{$key} = $args{value} if is_plain_hashref($args{value}); |
314
|
|
|
|
|
|
|
|
315
|
19
|
|
|
|
|
58
|
while (my ($field, $value) = each %args) { |
316
|
34
|
|
|
|
|
117
|
$self->{custom_data}{$key}{$field} = $value; |
317
|
|
|
|
|
|
|
} |
318
|
19
|
|
|
|
|
55
|
return $self->{custom_data}{$key}; |
319
|
|
|
|
|
|
|
} |
320
|
|
|
|
|
|
|
|
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
sub custom_data_value { |
323
|
6
|
|
|
6
|
1
|
58
|
my $self = shift; |
324
|
6
|
|
50
|
|
|
16
|
my $data = $self->custom_data(@_) // return undef; |
325
|
6
|
|
|
|
|
26
|
return $data->{value}; |
326
|
|
|
|
|
|
|
} |
327
|
|
|
|
|
|
|
|
328
|
|
|
|
|
|
|
############################################################################## |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
|
331
|
|
|
|
|
|
|
sub begin_work { |
332
|
35
|
|
|
35
|
1
|
1421
|
my $self = shift; |
333
|
|
|
|
|
|
|
|
334
|
35
|
100
|
|
|
|
73
|
if (defined wantarray) { |
335
|
16
|
|
|
|
|
969
|
require File::KDBX::Transaction; |
336
|
16
|
|
|
|
|
75
|
return File::KDBX::Transaction->new($self, @_); |
337
|
|
|
|
|
|
|
} |
338
|
|
|
|
|
|
|
|
339
|
19
|
|
|
|
|
40
|
my %args = @_; |
340
|
19
|
|
66
|
|
|
50
|
my $orig = $args{snapshot} // do { |
341
|
|
|
|
|
|
|
my $c = $self->clone( |
342
|
|
|
|
|
|
|
entries => $args{entries} // 0, |
343
|
|
|
|
|
|
|
groups => $args{groups} // 0, |
344
|
17
|
|
100
|
|
|
160
|
history => $args{history} // 0, |
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
345
|
|
|
|
|
|
|
); |
346
|
17
|
100
|
|
|
|
50
|
$c->{entries} = $self->{entries} if !$args{entries}; |
347
|
17
|
50
|
|
|
|
57
|
$c->{groups} = $self->{groups} if !$args{groups}; |
348
|
17
|
50
|
|
|
|
47
|
$c->{history} = $self->{history} if !$args{history}; |
349
|
17
|
|
|
|
|
39
|
$c; |
350
|
|
|
|
|
|
|
}; |
351
|
|
|
|
|
|
|
|
352
|
19
|
|
|
|
|
45
|
my $id = Hash::Util::FieldHash::id($orig); |
353
|
19
|
|
|
|
|
49
|
_save_references($id, $self, $orig); |
354
|
|
|
|
|
|
|
|
355
|
19
|
|
|
|
|
60
|
$self->_signal_begin_work; |
356
|
|
|
|
|
|
|
|
357
|
19
|
|
|
|
|
28
|
push @{$self->_txns}, $orig; |
|
19
|
|
|
|
|
38
|
|
358
|
|
|
|
|
|
|
} |
359
|
|
|
|
|
|
|
|
360
|
|
|
|
|
|
|
|
361
|
|
|
|
|
|
|
sub commit { |
362
|
14
|
|
|
14
|
1
|
23
|
my $self = shift; |
363
|
14
|
50
|
|
|
|
21
|
my $orig = pop @{$self->_txns} or return $self; |
|
14
|
|
|
|
|
23
|
|
364
|
14
|
|
|
|
|
52
|
$self->_commit($orig); |
365
|
14
|
|
|
|
|
191
|
my $signals = $self->_signal_commit; |
366
|
14
|
100
|
|
|
|
35
|
$self->_signal_send($signals) if !$self->_in_txn; |
367
|
14
|
|
|
|
|
80
|
return $self; |
368
|
|
|
|
|
|
|
} |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
|
371
|
|
|
|
|
|
|
sub rollback { |
372
|
5
|
|
|
5
|
1
|
7
|
my $self = shift; |
373
|
|
|
|
|
|
|
|
374
|
5
|
50
|
|
|
|
7
|
my $orig = pop @{$self->_txns} or return $self; |
|
5
|
|
|
|
|
7
|
|
375
|
|
|
|
|
|
|
|
376
|
5
|
|
|
|
|
13
|
my $id = Hash::Util::FieldHash::id($orig); |
377
|
5
|
|
|
|
|
13
|
_restore_references($id, $orig); |
378
|
|
|
|
|
|
|
|
379
|
5
|
|
|
|
|
19
|
$self->_signal_rollback; |
380
|
|
|
|
|
|
|
|
381
|
5
|
|
|
|
|
45
|
return $self; |
382
|
|
|
|
|
|
|
} |
383
|
|
|
|
|
|
|
|
384
|
|
|
|
|
|
|
# Get whether or not there is at least one pending transaction. |
385
|
82
|
|
|
82
|
|
102
|
sub _in_txn { scalar @{$_[0]->_txns} } |
|
82
|
|
|
|
|
174
|
|
386
|
|
|
|
|
|
|
|
387
|
|
|
|
|
|
|
# Get an array ref of pending transactions. |
388
|
152
|
|
100
|
152
|
|
892
|
sub _txns { $TXNS{$_[0]} //= [] } |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
# The _commit hook notifies subclasses that a commit has occurred. |
391
|
0
|
|
|
0
|
|
0
|
sub _commit { die 'Not implemented' } |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
# Get a reference to an object that represents an object's committed state. If there is no pending |
394
|
|
|
|
|
|
|
# transaction, this is just $self. If there is a transaction, this is the snapshot take before the transaction |
395
|
|
|
|
|
|
|
# began. This method is private because it provides direct access to the actual snapshot. It is important that |
396
|
|
|
|
|
|
|
# the snapshot not be changed or a rollback would roll back to an altered state. |
397
|
|
|
|
|
|
|
# This is used by File::KDBX::Dumper::XML so as to not dump uncommitted changes. |
398
|
|
|
|
|
|
|
sub _committed { |
399
|
32
|
|
|
32
|
|
56
|
my $self = shift; |
400
|
32
|
|
|
|
|
46
|
my ($orig) = @{$self->_txns}; |
|
32
|
|
|
|
|
97
|
|
401
|
32
|
|
66
|
|
|
223
|
return $orig // $self; |
402
|
|
|
|
|
|
|
} |
403
|
|
|
|
|
|
|
|
404
|
|
|
|
|
|
|
# In addition to cloning an object when beginning work, we also keep track its hashrefs and arrayrefs |
405
|
|
|
|
|
|
|
# internally so that we can restore to the very same structures in the case of a rollback. |
406
|
|
|
|
|
|
|
sub _save_references { |
407
|
1406
|
|
|
1406
|
|
1626
|
my $id = shift; |
408
|
1406
|
|
|
|
|
1526
|
my $self = shift; |
409
|
1406
|
|
|
|
|
1443
|
my $orig = shift; |
410
|
|
|
|
|
|
|
|
411
|
1406
|
100
|
100
|
|
|
4376
|
if (is_plain_arrayref($orig)) { |
|
|
100
|
66
|
|
|
|
|
412
|
67
|
|
|
|
|
128
|
for (my $i = 0; $i < @$orig; ++$i) { |
413
|
20
|
|
|
|
|
50
|
_save_references($id, $self->[$i], $orig->[$i]); |
414
|
|
|
|
|
|
|
} |
415
|
67
|
|
|
|
|
208
|
$REFS{$id}{Hash::Util::FieldHash::id($orig)} = $self; |
416
|
|
|
|
|
|
|
} |
417
|
|
|
|
|
|
|
elsif (is_plain_hashref($orig) || (blessed $orig && $orig->isa(__PACKAGE__))) { |
418
|
349
|
|
|
|
|
744
|
for my $key (keys %$orig) { |
419
|
1367
|
|
|
|
|
2031
|
_save_references($id, $self->{$key}, $orig->{$key}); |
420
|
|
|
|
|
|
|
} |
421
|
349
|
|
|
|
|
1082
|
$REFS{$id}{Hash::Util::FieldHash::id($orig)} = $self; |
422
|
|
|
|
|
|
|
} |
423
|
|
|
|
|
|
|
} |
424
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
# During a rollback, copy data from the snapshot back into the original internal structures. |
426
|
|
|
|
|
|
|
sub _restore_references { |
427
|
377
|
|
|
377
|
|
395
|
my $id = shift; |
428
|
377
|
|
100
|
|
|
553
|
my $orig = shift // return; |
429
|
329
|
|
50
|
|
|
1668
|
my $self = delete $REFS{$id}{Hash::Util::FieldHash::id($orig) // ''} // return $orig; |
|
|
|
100
|
|
|
|
|
430
|
|
|
|
|
|
|
|
431
|
108
|
100
|
33
|
|
|
269
|
if (is_plain_arrayref($orig)) { |
|
|
50
|
66
|
|
|
|
|
432
|
19
|
|
|
|
|
33
|
@$self = map { _restore_references($id, $_) } @$orig; |
|
6
|
|
|
|
|
10
|
|
433
|
|
|
|
|
|
|
} |
434
|
|
|
|
|
|
|
elsif (is_plain_hashref($orig) || (blessed $orig && $orig->isa(__PACKAGE__))) { |
435
|
89
|
|
|
|
|
161
|
for my $key (keys %$orig) { |
436
|
|
|
|
|
|
|
# next if is_ref($orig->{$key}) && |
437
|
|
|
|
|
|
|
# (Hash::Util::FieldHash::id($self->{$key}) // 0) == Hash::Util::FieldHash::id($orig->{$key}); |
438
|
366
|
|
|
|
|
483
|
$self->{$key} = _restore_references($id, $orig->{$key}); |
439
|
|
|
|
|
|
|
} |
440
|
|
|
|
|
|
|
} |
441
|
|
|
|
|
|
|
|
442
|
108
|
|
|
|
|
191
|
return $self; |
443
|
|
|
|
|
|
|
} |
444
|
|
|
|
|
|
|
|
445
|
|
|
|
|
|
|
############################################################################## |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
sub _signal { |
448
|
68
|
|
|
68
|
|
95
|
my $self = shift; |
449
|
68
|
|
|
|
|
90
|
my $type = shift; |
450
|
|
|
|
|
|
|
|
451
|
68
|
50
|
|
|
|
151
|
if ($self->_in_txn) { |
452
|
0
|
|
|
|
|
0
|
my $stack = $self->_signal_stack; |
453
|
0
|
|
|
|
|
0
|
my $queue = $stack->[-1]; |
454
|
0
|
|
|
|
|
0
|
push @$queue, [$type, @_]; |
455
|
|
|
|
|
|
|
} |
456
|
|
|
|
|
|
|
|
457
|
68
|
|
|
|
|
270
|
$self->_signal_send([[$type, @_]]); |
458
|
|
|
|
|
|
|
|
459
|
68
|
|
|
|
|
272
|
return $self; |
460
|
|
|
|
|
|
|
} |
461
|
|
|
|
|
|
|
|
462
|
52
|
|
100
|
52
|
|
238
|
sub _signal_stack { $SIGNALS{$_[0]} //= [] } |
463
|
|
|
|
|
|
|
|
464
|
|
|
|
|
|
|
sub _signal_begin_work { |
465
|
19
|
|
|
19
|
|
24
|
my $self = shift; |
466
|
19
|
|
|
|
|
24
|
push @{$self->_signal_stack}, []; |
|
19
|
|
|
|
|
46
|
|
467
|
|
|
|
|
|
|
} |
468
|
|
|
|
|
|
|
|
469
|
|
|
|
|
|
|
sub _signal_commit { |
470
|
14
|
|
|
14
|
|
22
|
my $self = shift; |
471
|
14
|
|
|
|
|
18
|
my $signals = pop @{$self->_signal_stack}; |
|
14
|
|
|
|
|
34
|
|
472
|
14
|
|
100
|
|
|
32
|
my $previous = $self->_signal_stack->[-1] // []; |
473
|
14
|
|
|
|
|
29
|
push @$previous, @$signals; |
474
|
14
|
|
|
|
|
25
|
return $previous; |
475
|
|
|
|
|
|
|
} |
476
|
|
|
|
|
|
|
|
477
|
|
|
|
|
|
|
sub _signal_rollback { |
478
|
5
|
|
|
5
|
|
9
|
my $self = shift; |
479
|
5
|
|
|
|
|
6
|
pop @{$self->_signal_stack}; |
|
5
|
|
|
|
|
8
|
|
480
|
|
|
|
|
|
|
} |
481
|
|
|
|
|
|
|
|
482
|
|
|
|
|
|
|
sub _signal_send { |
483
|
80
|
|
|
80
|
|
109
|
my $self = shift; |
484
|
80
|
|
50
|
|
|
183
|
my $signals = shift // []; |
485
|
|
|
|
|
|
|
|
486
|
80
|
50
|
|
|
|
212
|
my $kdbx = $KDBX{$self} or return; |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
# de-duplicate, keeping the most recent signal for each type |
489
|
80
|
|
|
|
|
101
|
my %seen; |
490
|
80
|
|
|
|
|
151
|
my @signals = grep { !$seen{$_->[0]}++ } reverse @$signals; |
|
68
|
|
|
|
|
290
|
|
491
|
|
|
|
|
|
|
|
492
|
80
|
|
|
|
|
164
|
for my $sig (reverse @signals) { |
493
|
68
|
|
|
|
|
193
|
$kdbx->_handle_signal($self, @$sig); |
494
|
|
|
|
|
|
|
} |
495
|
|
|
|
|
|
|
} |
496
|
|
|
|
|
|
|
|
497
|
|
|
|
|
|
|
############################################################################## |
498
|
|
|
|
|
|
|
|
499
|
|
|
|
|
|
|
sub _wrap_group { |
500
|
54
|
|
|
54
|
|
78
|
my $self = shift; |
501
|
54
|
|
|
|
|
64
|
my $group = shift; |
502
|
54
|
|
|
|
|
168
|
require File::KDBX::Group; |
503
|
54
|
|
|
|
|
145
|
return File::KDBX::Group->wrap($group, $KDBX{$self}); |
504
|
|
|
|
|
|
|
} |
505
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
sub _wrap_entry { |
507
|
59
|
|
|
59
|
|
103
|
my $self = shift; |
508
|
59
|
|
|
|
|
122
|
my $entry = shift; |
509
|
59
|
|
|
|
|
3113
|
require File::KDBX::Entry; |
510
|
59
|
|
|
|
|
291
|
return File::KDBX::Entry->wrap($entry, $KDBX{$self}); |
511
|
|
|
|
|
|
|
} |
512
|
|
|
|
|
|
|
|
513
|
0
|
|
|
0
|
0
|
|
sub TO_JSON { +{%{$_[0]}} } |
|
0
|
|
|
|
|
|
|
514
|
|
|
|
|
|
|
|
515
|
|
|
|
|
|
|
1; |
516
|
|
|
|
|
|
|
|
517
|
|
|
|
|
|
|
__END__ |