• Home
  • Features
  • Pricing
  • Docs
  • Announcements
  • Sign In

DrHyde / perl-modules-Data-Transactional / 10204671646

01 Aug 2024 07:37PM UTC coverage: 90.0%. Remained the same
10204671646

Pull #20

github

web-flow
Bump cross-platform-actions/action from 0.24.0 to 0.25.0

Bumps [cross-platform-actions/action](https://github.com/cross-platform-actions/action) from 0.24.0 to 0.25.0.
- [Release notes](https://github.com/cross-platform-actions/action/releases)
- [Changelog](https://github.com/cross-platform-actions/action/blob/master/changelog.md)
- [Commits](https://github.com/cross-platform-actions/action/compare/v0.24.0...v0.25.0)

---
updated-dependencies:
- dependency-name: cross-platform-actions/action
  dependency-type: direct:production
  update-type: version-update:semver-minor
...

Signed-off-by: dependabot[bot] <support@github.com>
Pull Request #20: Bump cross-platform-actions/action from 0.24.0 to 0.25.0

126 of 140 relevant lines covered (90.0%)

12.16 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

88.24
/lib/Data/Transactional.pm
1
package Data::Transactional;
2

3
use strict;
4✔
4
use warnings;
4✔
5

6
our $VERSION = '1.04';
7

8
use Data::Dumper;
4✔
9

10
=head1 NAME
11

12
Data::Transactional - data structures with RDBMS-like transactions
13

14
=head1 SYNOPSIS
15

16
    use Data::Transactional;
17

18
    my $data = Data::Transactional->new(type => 'hash');
19
    $data->{food_and_drink} = [ [], [] ];
20
    $data->checkpoint();
21
    $data->{food_and_drink}->[0] = [qw(pie curry chips)];
22
    $data->checkpoint();
23
    $data->{food_and_drink}->[1] = [qw(beer gin whisky)];
24
    $data->rollback();   # back to last checkpoint
25

26
=head1 METHODS
27

28
=over
29

30
=item new
31

32
The constructor.  This takes named parameters.  The only parameter
33
so far is:
34

35
=over
36

37
=item type
38

39
Optional parameter, taking either 'ARRAY' or 'HASH' as its value (case-
40
insensitive), to determine what data type to base the structure on.
41
Regardless of what you choose for the first level of the structure, you
42
may use whatever you like further down the tree.  If not supplied, this
43
defaults to 'HASH'.
44

45
=back
46

47
=cut
48

49
sub new {
50
    my($class, %args) = @_;
26✔
51
    my $self;
26✔
52

53
    $args{type} ||= 'HASH'; $args{type} = uc($args{type});
26✔
54

55
    if($args{type} eq 'HASH') {
26✔
56
        tie %{$self}, __PACKAGE__.'::Hash';
12✔
57
    } elsif($args{type} eq 'ARRAY') {
58
        tie @{$self}, __PACKAGE__.'::Array';
14✔
59
    } else {
60
        die(__PACKAGE__."::new(): type '$args{type}' unknown\n");
×
61
    }
62

63
    return bless $self, $class;
26✔
64
}
65

66
=item checkpoint
67

68
Saves the current state of the structure so that we can roll back to it.
69

70
=cut
71

72
sub checkpoint {
73
    my $self = shift;
9✔
74
    (tied %{$self})->checkpoint();
9✔
75
}
76

77
=item commit
78

79
Discards the most recent saved state, so it can no longer be rolled back.
80
Why do this?  Well, throwing away the history saves a load of memory.
81
It is a fatal error to commit() when there's no saved states.
82

83
=cut
84

85
# should this also commit_all in sub-structures?
86
sub commit {
87
    my $self = shift;
5✔
88
    (tied %{$self})->commit();
5✔
89
}
90

91
=item commit_all
92

93
Throws away all saved states, effectively committing all current transactions.
94

95
=cut
96

97
sub commit_all {
98
    my $self = shift;
1✔
99
    undef $@;
1✔
100
    while(!$@) { eval { $self->commit(); }; }
1✔
101
}
102

103
=item rollback
104

105
Revert the data structure to the last checkpoint.  To roll back beyond the
106
first checkpoint is a fatal error.
107

108
=cut
109

110
sub rollback {
111
    my $self = shift;
10✔
112
    (tied %{$self})->rollback();
10✔
113
}
114

115
=item rollback_all
116

117
Roll back all changes.
118

119
=cut
120

121
sub rollback_all {
122
    my $self = shift;
1✔
123
    undef $@;
1✔
124
    while(!$@) { eval { $self->rollback(); }; }
1✔
125
}
126

127
=item current_state
128

129
Return a reference to the current state of the underlying object.
130

131
=cut
132

133
sub current_state {
134
    my $self = shift;
75✔
135
    return $self->isa('HASH') ?
136
        tied(%{$self})->current_state() :
32✔
137
        tied(@{$self})->current_state();
75✔
138
}
139

140
=back
141

142
=head1 IMPLEMENTATION NOTES
143

144
This module relies on two other packages which are included in the same
145
file - Data::Transactional::Hash and Data::Transactional::Array.  These
146
are where the magic really happens.  These implement everything needed
147
for C<tie()>ing those structures, plus their own C<checkpoint()>,
148
C<commit()> and C<rollback()> methods.  When you create a
149
Data::Transactional object, what you really get is one of these tied
150
structures, reblessed into the Data::Transactional class.  The
151
transactional methods simply call through to the same method on the
152
underlying tied structure.
153

154
This is loosely inspired by L<DBM::Deep>.
155

156
=head1 BUGS/WARNINGS
157

158
I assume that C<$[> is zero.
159

160
Storing blessed objects in a C<Data::Transactional> structure is not
161
supported.  I suppose it could be, but there's no sane way that they
162
could be transactionalised.  This also applies to tie()d objects.
163
Please note that in the case of tie()d objects, we don't do a great deal
164
of checking, so things may break in subtle and hard-to-debug ways.
165

166
The precise details of how the transactional methods affect sub-structures
167
in your data may change before a 1.0 release.  If you have suggestions for
168
how it could be improved, do please let me know.
169

170
The SPLICE() operation is *not defined* for transactionalised arrays,
171
because it makes my brane hurt.  If you want to implement this please
172
do!  Remember that you should use STORE() to put each new entry in the
173
array, as that will properly handle adding complex data structures.
174

175
No doubt there are others.  When submitting a bug report please please
176
please include a test case, in the form of a .t file, which will fail
177
with my version of the module and pass once the bug is fixed.  If you
178
include a patch as well, that's even better!
179

180
=head1 FEEDBACK
181

182
I welcome all comments - both praise and constructive criticism - about
183
my code.  If you have a question about how to use it please read *all*
184
of the documentation first, and let me know what you have tried and how
185
the results differ from what you wanted or expected.
186

187
I do not consider blind, automatically generated and automatically sent
188
error reports to be constructive.
189
Don't send them, you'll only get flamed.
190

191
=head1 AUTHOR
192

193
David Cantrell E<lt>david@cantrell.org.ukE<gt>
194

195
=head1 LICENCE
196

197
This software is Copyright 2004 David Cantrell.  You may use, modify and
198
distribute it under the same terms as perl itself.
199

200
=cut
201

202
package Data::Transactional::Hash;
203
use Storable qw(dclone);
4✔
204
use strict;use warnings;
4✔
205

206
sub TIEHASH {
207
    my $class = shift;
12✔
208
    my $self = {
12✔
209
        STACK           => [],
210
        CURRENT_STATE   => {},
211
    };
212

213
    return bless $self, $class;
12✔
214
}
215

216
sub CLEAR {
217
    my $self=shift;
4✔
218
    $self->{CURRENT_STATE}={};
4✔
219
}
220

221
sub STORE {
222
    my($self, $key, $value)=@_;
27✔
223
    my $newobj = $value;
27✔
224
    if(ref($value)) {
27✔
225
        if(ref($value) eq 'ARRAY') {
16✔
226
            $newobj = Data::Transactional->new(type => 'ARRAY');
12✔
227
            # @{$newobj} = @{$value};
228
            push @{$newobj}, $_ foreach(@{$value});
12✔
229
        } elsif(ref($value) eq 'HASH') {
230
            $newobj = Data::Transactional->new(type => 'HASH');
3✔
231
            # %{$newobj} = %{$value};
232
            $newobj->{$_} = $value->{$_} foreach(keys %{$value});
3✔
233
        } else {
234
            die(__PACKAGE__."::STORE(): don't know how to store a ".ref($value)."\n");
1✔
235
        }
236
    }
237
    $self->{CURRENT_STATE}->{$key} = $newobj;
26✔
238
}
239

240
sub FETCH {
241
    my($self, $key) = @_;
28✔
242
    $self->{CURRENT_STATE}->{$key};
28✔
243
}
244

245
sub FIRSTKEY {
246
    my $self = shift;
8✔
247
    scalar keys %{$self->{CURRENT_STATE}};   # reset iterator
8✔
248
    # scalar each %{$self->{CURRENT_STATE}};
249
    $self->NEXTKEY();
8✔
250
}
251

252
sub NEXTKEY { my $self = shift; scalar each %{$self->{CURRENT_STATE}}; }
36✔
253
sub DELETE { my($self, $key) = @_; delete $self->{CURRENT_STATE}->{$key}; }
2✔
254
sub EXISTS { my($self, $key) = @_; exists($self->{CURRENT_STATE}->{$key}); }
2✔
255

256
sub checkpoint {
257
    my $self = shift;
9✔
258
    # make a new copy of CURRENT_STATE before putting on stack,
259
    # otherwise CURRENT_STATE and top-of-STACK will reference the
260
    # same data structure, which would be a Bad Thing
261
    push @{$self->{STACK}}, dclone($self->{CURRENT_STATE});
9✔
262
}
263

264
sub commit {
265
    my $self = shift;
5✔
266
    # $self->{STACK}=[];                     # clear all checkpoints
267
    defined(pop(@{$self->{STACK}})) ||
5✔
268
        die("Attempt to commit without a checkpoint");
269
}
270

271
sub rollback {
272
    my $self = shift;
10✔
273
    die("Attempt to rollback too far") unless(@{$self->{STACK}});
10✔
274
    # no copying required, just update a pointer
275
    $self->{CURRENT_STATE}=pop @{$self->{STACK}};
6✔
276
}
277

278
sub current_state {
279
    shift->{CURRENT_STATE};
32✔
280
}
281

282
package Data::Transactional::Array;
283
use Storable qw(dclone);
4✔
284
use strict;use warnings;
4✔
285

286
sub TIEARRAY {
287
    my $class = shift;
14✔
288
    my $self = {
14✔
289
        STACK           => [],
290
        CURRENT_STATE   => [],
291
    };
292

293
    return bless $self, $class;
14✔
294
}
295

296
sub CLEAR {
297
    my $self=shift;
1✔
298
    $self->{CURRENT_STATE}=[];
1✔
299
}
300

301
sub STORE {
302
    my($self, $index, $value)=@_;
52✔
303
    my $newobj = $value;
52✔
304
    if(ref($value)) {
52✔
305
        if(ref($value) eq 'ARRAY') {
3✔
306
            $newobj = Data::Transactional->new(type => 'ARRAY');
×
307
            # @{$newobj} = @{$value};
308
            push @{$newobj}, $_ foreach(@{$value});
×
309
        } elsif(ref($value) eq 'HASH') {
310
            $newobj = Data::Transactional->new(type => 'HASH');
2✔
311
            # %{$newobj} = %{$value};
312
            $newobj->{$_} = $value->{$_} foreach(keys %{$value});
2✔
313
        } else {
314
            die(__PACKAGE__."::STORE(): don't know how to store a ".ref($value)."\n");
1✔
315
        }
316
    }
317
    $self->{CURRENT_STATE}->[$index] = $newobj;
51✔
318
}
319

320
sub FETCH {
321
    my($self, $index) = @_;
10✔
322
    $self->{CURRENT_STATE}->[$index];
10✔
323
}
324

325
sub DELETE { my($self, $index) = @_; delete $self->{CURRENT_STATE}->[$index]; }
3✔
326
sub EXISTS { my($self, $index) = @_; exists($self->{CURRENT_STATE}->[$index]); }
2✔
327
sub POP { my $self = shift; pop @{$self->{CURRENT_STATE}}; }
2✔
328
sub SHIFT { my $self = shift; shift @{$self->{CURRENT_STATE}}; }
1✔
329

330
sub PUSH {
331
    my($self, @list) = @_;
42✔
332
    $self->STORE($self->FETCHSIZE(), $_) foreach (@list);
42✔
333
}
334

335
sub UNSHIFT {
336
    my($self, @list) = @_;
1✔
337
    my @oldlist = @{$self->{CURRENT_STATE}};
1✔
338
    # shuffle existing contents along
339
    for(my $i = $self->FETCHSIZE() - 1; $i >= 0; $i--) {
1✔
340
        $self->{CURRENT_STATE}->[$i + scalar(@list)] =
341
            $self->{CURRENT_STATE}->[$i];
4✔
342
    }
343
    $self->STORE($_, $list[$_]) foreach(0..$#list);
1✔
344
    return $self->FETCHSIZE();
1✔
345
}
346

347
# # FIXME - this needs to shuffle stuff as UNSHIFT does, then use STORE
348
# # for anything we insert
349
# sub SPLICE {
350
# }
351

352
sub FETCHSIZE { my $self = shift; scalar(@{$self->{CURRENT_STATE}}); }
51✔
353
sub STORESIZE {
354
    my($self, $count) = @_;
×
355
    $self->{CURRENT_STATE} = [(@{$self->{CURRENT_STATE}})[0..$count - 1]];
×
356
}
357
sub EXTEND { 'the voices told me to write this method' }
1✔
358

359
sub checkpoint {
360
    my $self = shift;
×
361
    push @{$self->{STACK}}, dclone($self->{CURRENT_STATE});
×
362
}
363

364
sub commit {
365
    my $self = shift;
×
366
    # $self->{STACK}=[];                     # clear all checkpoints
367
    defined(pop(@{$self->{STACK}})) ||
×
368
        die("Attempt to commit without a checkpoint");
369
}
370

371
sub rollback {
372
    my $self = shift;
×
373
    die("Attempt to rollback too far") unless(@{$self->{STACK}});
×
374
    # no copying required, just update a pointer
375
    $self->{CURRENT_STATE} = pop @{$self->{STACK}};
×
376
}
377

378
sub current_state {
379
    shift->{CURRENT_STATE};
43✔
380
}
STATUS · Troubleshooting · Open an Issue · Sales · Support · CAREERS · ENTERPRISE · START FREE · SCHEDULE DEMO
ANNOUNCEMENTS · TWITTER · TOS & SLA · Supported CI Services · What's a CI service? · Automated Testing

© 2025 Coveralls, Inc