File Coverage

blib/lib/Net/DAV/Lock.pm
Criterion Covered Total %
statement 61 61 100.0
branch 37 38 97.3
condition n/a
subroutine 13 13 100.0
pod 0 12 0.0
total 111 124 89.5


line stmt bran cond sub pod time code
1             package Net::DAV::Lock;
2              
3 17     17   51305 use Net::DAV::UUID;
  17         54  
  17         18545  
4              
5             our $MAX_LOCK_TIMEOUT = 15 * 60;
6             our $DEFAULT_LOCK_TIMEOUT = $MAX_LOCK_TIMEOUT;
7             our $DEFAULT_DEPTH = 'infinity'; # as per RFC 4918, section 9.10.3, paragraph 5
8             our $DEFAULT_SCOPE = 'exclusive';
9              
10             our $VERSION = '1.305';
11             $VERSION = eval $VERSION;
12              
13             sub new {
14 82     82 0 6521 my ($class, $hash) = @_;
15 82         130 my $obj = {};
16              
17 82         242 my $now = time();
18              
19 82 100       308 die('Missing path value') unless defined $hash->{'path'};
20 80         441 $obj->{'path'} = $hash->{'path'};
21              
22 80 100       209 die('Missing creator value') unless defined $hash->{'creator'};
23 79 100       581 die('Owner contains invalid characters') unless $hash->{'creator'} =~ /^[a-z_.][-a-z0-9_.]*$/;
24 78         163 $obj->{'creator'} = $hash->{'creator'};
25 78 100       208 die('Missing owner value') unless defined $hash->{'owner'};
26 77         152 $obj->{'owner'} = $hash->{'owner'};
27              
28 77 100       301 if (defined $hash->{'expiry'}) {
    100          
29 20 100       96 die('Lock expiry is a date in the past') if $hash->{'expiry'} < $now;
30 19 100       117 if ($hash->{'expiry'} - $now > $MAX_LOCK_TIMEOUT) {
31 1         3 $obj->{'expiry'} = $now + $MAX_LOCK_TIMEOUT;
32             }
33             else {
34 18         48 $obj->{'expiry'} = $hash->{'expiry'};
35             }
36             } elsif (defined $hash->{'timeout'}) {
37 2 100       26 if ($hash->{'timeout'} > $MAX_LOCK_TIMEOUT) {
38 1         2 $obj->{'expiry'} = $now + $MAX_LOCK_TIMEOUT;
39             }
40             else {
41 1         3 $obj->{'expiry'} = $now + $hash->{'timeout'};
42             }
43             } else {
44 55         115 $obj->{'expiry'} = $now + $DEFAULT_LOCK_TIMEOUT;
45             }
46              
47 76 100       160 if (defined $hash->{'depth'}) {
48 24 100       168 die('Depth is a non-RFC 4918 value') unless $hash->{'depth'} =~ /^(?:0|infinity)$/;
49 23         59 $obj->{'depth'} = $hash->{'depth'};
50             } else {
51 52         122 $obj->{'depth'} = $DEFAULT_DEPTH;
52             }
53              
54 75 100       163 if (defined $hash->{'scope'}) {
55 19 100       99 die('Scope is an unsupported value') unless $hash->{'scope'} eq 'exclusive';
56 18         42 $obj->{'scope'} = $hash->{'scope'};
57             } else {
58 56         173 $obj->{'scope'} = $DEFAULT_SCOPE;
59             }
60              
61 74         142 $obj->{'uri'} = $hash->{'uri'};
62              
63             #
64             # Calculate and store a new UUID based on the path and owner
65             # specified, if none is present.
66             #
67 74 100       288 if ($hash->{'uuid'}) {
    100          
68 2 100       12 unless ($hash->{'uuid'} =~ /^[0-9a-f]{8}(?:-[0-9a-f]{4}){3}-[0-9a-f]{12}$/) {
69 1         8 die('UUID is of an invalid format');
70             }
71              
72 1         3 $obj->{'uuid'} = $hash->{'uuid'};
73             } elsif ($hash->{'token'}) {
74 3 100       13 unless ($hash->{'token'} =~ /^opaquelocktoken:[0-9a-f]{8}(?:-[0-9a-f]{4}){3}-[0-9a-f]{12}$/) {
75 2         14 die('Token is not a UUID prefixed with the opaquelocktoken: URI namespace');
76             }
77              
78 1         3 my $uuid = $hash->{'token'};
79 1         4 $uuid =~ s/^opaquelocktoken://;
80              
81 1         4 $obj->{'uuid'} = $uuid;
82             } else {
83 69         224 $obj->{'uuid'} = Net::DAV::UUID::generate(@{$hash}{qw/path owner/});
  69         309  
84             }
85              
86 71         467 return bless $obj, $class;
87             }
88              
89             #
90             # Provide a separate constructor for reanimating values from the database,
91             # especially when the validation within the normal constructor would be
92             # considered undesired behavior.
93             #
94             # Results in a simple copy of the database row into a blessed object.
95             #
96             sub reanimate {
97 10     10 0 27 my ($class, $row) = @_;
98              
99 10         114 bless { %$row }, $class;
100             }
101              
102 83     83 0 968 sub expiry { shift->{'expiry'} };
103 44     44 0 633 sub creator { shift->{'creator'} };
104 7     7 0 41 sub owner { shift->{'owner'} };
105 44     44 0 312 sub depth { shift->{'depth'} };
106 7     7 0 29 sub scope { shift->{'scope'} };
107 351     351 0 11097 sub path { shift->{'path'} };
108 83     83 0 536 sub uuid { shift->{'uuid'} };
109              
110             #
111             # Return the number of seconds remaining for which this lock is
112             # valid, relative to the current system time.
113             #
114             sub timeout {
115 2     2 0 9 my ($self) = @_;
116              
117 2         4 my $left = $self->{'expiry'} - time();
118              
119 2 50       8 return $left >= 0? $left: 0;
120             }
121              
122             #
123             # Provide a wrapper method to return a token URI based on the UUID
124             # stored in the current object.
125             #
126             sub token {
127 71     71 0 1237 my ($self) = @_;
128              
129 71         153 return 'opaquelocktoken:' . $self->uuid;
130             }
131              
132             #
133             # Update the expiration date of this lock. Throw an error if the update
134             # is not for any time in the future.
135             #
136             # The rationale for providing this method as a means of setting a new
137             # value for the lock expiration date is that without it, the immutable
138             # nature of this class forces the creation of a new lock object, which
139             # would be undesirable as the existing UUID should be preserved.
140             #
141             sub renew {
142 6     6 0 27 my ($self, $expiry) = @_;
143              
144 6 100       28 die('New lock expiration date is not in the future') unless $expiry > time();
145              
146 5         12 $self->{'expiry'} = $expiry;
147              
148 5         12 return $self;
149             }
150              
151             1;
152              
153             __END__