File Coverage

blib/lib/App/PTP/Util.pm
Criterion Covered Total %
statement 31 47 65.9
branch 2 10 20.0
condition n/a
subroutine 12 19 63.1
pod 0 1 0.0
total 45 77 58.4


line stmt bran cond sub pod time code
1             # This module provides various helper function used throughout the program.
2              
3             package App::PTP::Util;
4              
5 17     17   327 use 5.022;
  17         57  
6 17     17   87 use strict;
  17         32  
  17         389  
7 17     17   79 use warnings;
  17         27  
  17         11618  
8              
9             # More or less the same as List::Util::uniqstr (or List::Util::uniq). Provided
10             # here because the List::Util function is not available in 5.22 by default.
11             sub uniqstr (@) {
12 2     2 0 239 my (@l) = @_;
13 2         13 for my $i (0 .. $#l - 1) {
14 124 100       204 undef $l[$i] if $l[$i] eq $l[$i+1];
15             }
16 2         10 return grep { defined } @l;
  126         192  
17             }
18              
19             {
20             # A simple way to make a scalar be read-only.
21             package App::PTP::Util::ReadOnlyVar;
22             sub TIESCALAR {
23 85     85   169 my ($class, $value) = @_;
24 85         208 return bless \$value, $class;
25             }
26             sub FETCH {
27 109     109   2624 my ($self) = @_;
28 109         634 return $$self;
29             }
30             # Does nothing. We could warn_or_die, but it does not play well with the fact
31             # that we are inside the safe.
32       0     sub STORE {}
33             # Secret hidden methods for our usage only. These methods can't be used
34             # through the tie-ed variable, but only through the object returned by the
35             # call to tie.
36             sub set {
37 1165     1165   2226 my ($self, $value) = @_;
38 1165         2284 $$self = $value;
39             }
40             sub get {
41 0     0   0 my ($self, $value) = @_;
42 0         0 return $$self;
43             }
44             sub inc {
45 139     139   283 my ($self) = @_;
46 139         641 ++$$self;
47             }
48             }
49              
50             {
51             # A simple way to make a scalar be an alias of another one.
52             package App::PTP::Util::AliasVar;
53             sub TIESCALAR {
54 17     17   71 my ($class) = @_;
55 17         31 my $var;
56 17         61 return bless \$var, $class;
57             }
58             sub FETCH {
59 10     10   17 my ($self) = @_;
60 10         37 return $$$self;
61             }
62             sub STORE {
63 0     0   0 my ($self, $value) = @_;
64 0         0 $$$self = $value;
65             }
66             # Secret hidden methods for our usage only. These methods can't be used
67             # through the tie-ed variable, but only through the object returned by the
68             # call to tie.
69             sub set {
70 558     558   945 my ($self, $ref) = @_;
71 558         1050 $$self = $ref;
72             }
73             }
74              
75             {
76             # A fake array that returns the marker at a given offset from the current
77             # line.
78             package App::PTP::Util::MarkersArray;
79             our $NEGATIVE_INDICES = 1;
80             sub TIEARRAY {
81 17     17   74 my ($class, $markers, $n) = @_;
82 17         49 my $this = [$markers, $n];
83 17         81 return bless $this, $class;
84             }
85             sub FETCH {
86 0     0     my ($self, $offset) = @_;
87 0           my $index = ($$self->[1] - 1 + $offset);
88 0 0         return 0 if $index < 0;
89 0 0         return 0 if $index >= $self->FETCHSIZE();
90 0           return $self->[0][$index];
91             }
92             sub FETCHSIZE {
93 0     0     my ($self) = @_;
94 0           return scalar(@App::PTP::Commands::markers);
95             }
96             sub STORE {
97 0     0     my ($self, $offset, $value) = @_;
98 0           my $index = ($$self->[1] - 1 + $offset);
99 0 0         return $value if $index < 0;
100 0 0         return $value if $index >= $self->FETCHSIZE();
101 0           $self->[0][$index] = $value;
102             }
103       0     sub STORESIZE {}
104             }
105              
106             1;