-
Notifications
You must be signed in to change notification settings - Fork 0
/
Signature.pm
508 lines (359 loc) · 15.4 KB
/
Signature.pm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
package File::Signature;
use strict;
use vars qw( $VERSION );
$VERSION = '1.10';
use Digest::MD5;
my @FIELDS = qw( digest ino mode uid gid size mtime pathname );
my @ERRFIELDS = qw( failure pathname errormsg );
my %CONFIG = (
allow_relative_paths => 0,
stringify_separator => "\0",
use_digest_format => 'hex',
);
sub configure {
_throw_exception( "argument required" ) unless @_;
_throw_exception( "odd argument list (not a hash?)" ) unless 0 == @_ % 2;
my %options = @_;
my $i = 0;
for my $opt ( keys %options ) {
$CONFIG{ $opt } = $options{ $opt }, $i++ if exists $CONFIG{ $opt };
}
return $i unless wantarray;
return %CONFIG;
}
##
# Note:
# Stringified error objects start with the stringify_separator. That
# allows us to support binary digests. Prefixing both is the alternative.
#
use overload '""' => sub {
if ( $_[0]->error ) {
return join $CONFIG{ stringify_separator }, "", "ERROR", $_[0]->error;
} else {
return join $CONFIG{ stringify_separator }, @{ $_[0] }{ @FIELDS };
}
};
sub new_from_string {
my $class = shift;
my $string = shift;
_throw_exception( "argument required" ) unless defined $string;
_throw_exception( "argument was null" ) unless length $string;
my $self = { };
# For convenience.
my $sep_regex = qr/\Q$CONFIG{ stringify_separator }\E/;
if ($string =~ s/^${ sep_regex }ERROR$sep_regex//) {
my @fields = split /$sep_regex/, $string, scalar( @ERRFIELDS );
_throw_exception( "bad errobj string" ) unless @fields == @ERRFIELDS;
@{ $self }{ @ERRFIELDS } = @fields;
} else {
my @fields = split /$sep_regex/, $string, scalar( @FIELDS );
_throw_exception( "bad object string" ) unless @fields == @FIELDS;
@{ $self }{ @FIELDS } = @fields;
}
bless $self, $class;
}
sub new {
my $class = shift;
my $pathname = shift;
_throw_exception( "pathname required" ) unless defined $pathname;
_throw_exception( "pathname was null" ) unless length $pathname;
unless ( $CONFIG{ allow_relative_paths } or 0 == index( $pathname, '/' ) ) {
require File::Spec;
$pathname = File::Spec->rel2abs( $pathname );
}
my @stat = stat $pathname;
return __PACKAGE__->_bad_sig( "stat failure", $pathname, $! ) unless @stat;
open my $fh, "<", $pathname
or return __PACKAGE__->_bad_sig( "open failure", $pathname, $! );
my $digest = do {
local $_ = $CONFIG{ use_digest_format };
/hex/ and Digest::MD5->new->addfile($fh)->hexdigest
or /b64/ and Digest::MD5->new->addfile($fh)->b64digest
or /bin/ and Digest::MD5->new->addfile($fh)->digest
or Digest::MD5->new->addfile($fh)->digest;
};
close $fh;
my $self = { };
@{ $self }{ @FIELDS } = ( $digest, @stat[1,2,4,5,7,9], $pathname );
return bless $self, $class;
}
# This is a private constructor for bad signatures.
sub _bad_sig {
my $class = shift;
my ( $failure, $pathname, $error ) = @_;
my $self = {
failure => $failure,
pathname => $pathname,
errormsg => $error,
};
bless $self, $class;
}
## Both normal signature objects and error objects will have a pathname.
sub pathname { shift->{ pathname } }
##
# The following are reserved accessors. They are unimplemented because
# I'm still considering their possible value. I believe that providing
# this information to the user is probably outside this module's scope
# but it may be useful just the same. Out of these, I am most inclined
# to provide the failure() and errormsg() routines.
sub failure { _throw_exception( 'unimplemented' ) }
sub errormsg { _throw_exception( 'unimplemented' ) }
sub digest { _throw_exception( 'unimplemented' ) }
sub ino { _throw_exception( 'unimplemented' ) }
sub mode { _throw_exception( 'unimplemented' ) }
sub uid { _throw_exception( 'unimplemented' ) }
sub gid { _throw_exception( 'unimplemented' ) }
sub size { _throw_exception( 'unimplemented' ) }
sub mtime { _throw_exception( 'unimplemented' ) }
#
##
sub error {
my $self = shift;
return undef unless exists $self->{ failure };
if (wantarray) {
( @{ $self }{ @ERRFIELDS } );
} else {
my $msg = __PACKAGE__;
$msg .= " ERROR: $self->{ failure } on '$self->{ pathname }'";
$msg .= " ($self->{ errormsg })" if exists $self->{ errormsg };
return $msg;
}
}
# Currently, this sub doesn't make sense it exists to provide functionality
# that will only become necessary if I add an update() method.
sub was_error {
my $self = shift;
return 1 if exists $self->{ old_sig } and $self->{ old_sig }->error;
return 0;
}
sub old_and_new {
my $self = shift;
my $field = shift;
# It doesn't make much sense to compare old and new error.
_throw_exception( "bad method call " . $self->error ) if ( $self->error );
return undef unless grep $field, @FIELDS;
return ( $self->{ old_sig }{ $field }, $self->{ $field } );
}
sub is_same {
my $self = shift;
# It doesn't make much sense to see if an error has changed.
_throw_exception( "bad method call " . $self->error ) if ( $self->error );
$self->_check_again;
return "$self" eq "$self->{old_sig}";
}
sub changed {
my $self = shift;
# It doesn't make much sense to see if an error has changed.
_throw_exception( "bad method call " . $self->error ) if ( $self->error );
$self->_check_again;
return "$self" ne "$self->{old_sig}" unless wantarray;
# XXX is string eq good enough here?
grep { $self->{ $_ } ne $self->{ old_sig }{ $_ } } @FIELDS;
}
## Private instance methods
# This will handle error objects too but it shouldn't get any, right now.
# The functionality is there in case I later decide to add an update()
# method to just update the signature rather than check it's state. For the
# time being, File::Signature->new($existing_sig->pathname) will have to do.
sub _check_again {
my $self = shift;
# Duplicate our $self and key the duplicate by "old_sig".
$self->{ old_sig } = __PACKAGE__->new_from_string( "$self" );
# Create a new signature with the same path name.
my $newsig = __PACKAGE__->new( $self->{ pathname } );
# Clean our $self up by removing old fields.
delete $self->{ $_ } for grep { $_ ne 'pathname' } @FIELDS, @ERRFIELDS;
# Copy the new signature into our $self one field at a time.
if ( $newsig->error ) {
$self->{ $_ } = $newsig->{ $_ } for ( @ERRFIELDS );
} else {
$self->{ $_ } = $newsig->{ $_ } for ( @FIELDS );
}
}
sub _throw_exception {
my $msg = shift;
my $subroutine = (caller(1))[3];
require Carp;
Carp::croak( "${subroutine}(): " . $msg );
}
1;
__END__
# Below is stub documentation for your module. You'd better edit it!
=head1 NAME
File::Signature - Detect changes to a file's content or attributes.
=head1 SYNOPSIS
use File::Signature;
my $sig = File::Signature->new('/some/file');
# If you have a stringified signature stored in $string
# you can create a File::Signature object from it.
my $sig = File::Signature->new_from_string($string);
if (my $err = $sig->error) {
warn $err, "\n";
}
# You can use a signature object to re-check the same file.
if ( $sig->is_same() ) { print "Ok. The signature is the same.\n" }
if ( $sig->changed() ) { print "Uh Oh! The signature has changed.\n" }
my @digests = $sig->old_and_new('digest');
my @inodes = $sig->old_and_new('ino');
my @modes = $sig->old_and_new('mode');
my @uid = $sig->old_and_new('uid');
my @gid = $sig->old_and_new('gid');
my @mtime = $sig->old_and_new('mtime');
# A slightly more worthwhile use...
my @fields = $sig->changed();
for my $field (@fields) {
printf "$field was: %s but changed to %s.\n",
$sig->old_and_new($field);
}
=head1 ABSTRACT
This perl library uses perl5 objects to assist in determining whether a file's
contents or attributes have changed. It maintains several pieces of information
about the file: a digest (currently only MD5 is supported), its inode number,
its mode, the uid of its owner, the gid of its group owner, and its last
modification time. A File::Signature object is closely associated with a single
pathname. It provides a way to compare the state of a file over different
points in time; it isn't useful for comparing different files.
=head1 DESCRIPTION
This module provides a way to monitor files for changes. It implements an object
oriented interface to file "signatures." In the case of this module, a
signature includes an MD5 digest (other digests may be added later), the file's
size, its inode number, its mode, its owner's uid, its group's gid, and its
mtime. This information is associated with a file by the file's "pathname." The
pathname is considered to be the file's unique identifier. In reality, a file
may have more than one pathname, but this module doesn't recognize that. It
will simply treat two differing pathnames as two different files, even if they
refer to the same file.
As this module checks whether a file changes over time, a minimal use of it
would include the time when the signature was created and a different
time when the signature is regenerated and compared with the previous one. The
amount of time between these checks is arbitrary. This module makes it
easy to save a signature object and then load it and check for consistency
at a later time, whether seconds or years have passed.
=head2 CONSTRUCTORS
=over 4
=item new()
This constructor requires a pathname argument. If one is not provided, it will
throw an exception (i.e. croak.) If the pathname cannot be stat()'d or if it
cannot be read, the object returned will hold an error accessible via the
error() instance method. The pathname should be absolute and, if it isn't it
well be resolved to an absolute pathname unless the "allow_relative_paths"
configure option is provided. See L</configure()> below.
=item new_from_string()
This constructor takes a single argument, a previously stringified signature
object, and returns a new signature object created from the string.
=back
=head2 INSTANCE METHODS
=over 4
=item error()
If there was a non-fatal error when the object was constructed or when the last
check was performed, a signature error object is returned instead. This method
determines whether the object is an error object. It returns false if it isn't
and a true value if it is. The true value in that case will be a human readable
error message in scalar context or, in list context, list containing a
"failure" message, the pathname, and an optional system error message.
=item is_same()
Updates the signature and checks whether it is the same. It returns true if it
is and false if it isn't. It will throw an exception (i.e. croak) if the
current signature object reports an error.
=item changed()
Updates the signature and checks whether it is has changed. It returns true if
it has and false if it hasn't. It will throw an exception (i.e. croak) if the
current signature object reports an error.
=item old_and_new()
This method requires a fieldname to be passes as a string. It returns a
two-element list consisting of the previous and current value for the field
with the supplied fieldname. If the fieldname is not recognized, it will return
undef. This is used primarily to determine what has changed once a change has
been detected with is_same() or changed(). The currently accepted fieldnames
are any of qw( digest ino mode uid gid size mtime pathname ). Note that the old
and new pathname fields should always be the same.
=back
=head2 OTHER CLASS METHODS
=over 4
=item configure()
This is used to configure special behavior for all instances. The options are
passes as hash where the keys are option names and the values are the desired
settings. The following keys are recognized:
=over 4
=item use_digest_format
This key may be either 'bin', 'hex', or 'b64' and will determine whether the
digest will be stored as a binary string, a string of hexadecimals, or a
base64 encoded string. The default is 'hex', but that should not be relied upon
as it may change in the future. An unrecognized value will result in a binary
string representation just as if 'bin' had been the value. If a binary string
is used, the L</stringify_separator> should not be changed from "\0"!
=item allow_relative_paths
A true value for this key will result in relative paths being permitted as the
pathname for signature objects. Usually, when a relative pathname is given in
a call to the new() constructor, the absolute path is determined. This option
disables that behavior. Changing this option is NOT RECOMMENDED.
=item stringify_separator
This option changes the field separator that is used when a signature object is
stringified. By default this separator is a null ("\0"). It can be changed to
any string but the string used must never appear in any of the fields. This
includes the fields of signature error objects which sometimes contain system
generated error messages. For example, colons and forward slashes are bad
choices. Changing this option is NOT RECOMMENDED.
=back
=back
=head2 EXCEPTIONS
This is a list of all exceptions that thrown by File::Signature:
=over 4
=item "argument required"
Thrown by configure() and new_from_string() when called with no
arguments.
=item "odd argument list (not a hash?)"
Thrown by configure() when called with an odd number of arguments. (It is to be
called with a hash.)
=item "argument was null"
Thrown by new_from_string() when called with an empty string.
=item "bad errobj string"
Thrown by new_from_string() when something that looks like a stringified
error object results in the wrong number of fields.
=item "bad object string"
Thrown by new_from_string() when something that looks like a stringified
signature object results in the wrong number of fields.
=item "pathname required"
Thrown by new() when called without an argument.
=item "pathname was null"
Thrown by new() when called without a null string as an argument.
=item "bad method call"
Thrown by is_same(), changed(), and old_and_new() when called on an error
object.
=back
=head2 EXPORT
None.
=head1 CHANGES
1.10 Sat May 5 06:36:42 EDT 2012
Removed old RCS Id and Log cruft. Fixed and added tests.
Contact info updated.
Revision 1.9 2003/08/12 19:53:03 jeremy
Fixups to tests.
Revision 1.8 2003/08/11 16:53:41 jeremy
Fixed bad POD.
Revision 1.7 2003/06/13 03:58:32 jeremy
Bug fixes, doc updates, minor changes.
Revision 1.6 2003/06/12 02:49:37 jeremy
_throw_exception() fixed. Additional error states handled in
constructors.
Revision 1.5 2003/06/10 22:03:11 jeremy
POD updates.
Revision 1.4 2003/06/08 12:59:25 jeremy
POD changes.
Revision 1.3 2003/06/08 12:36:24 jeremy
More minor prepping for RCS.
Revision 1.2 2003/06/08 12:33:38 jeremy
Minor touch-ups for RCS prepping.
=head1 SEE ALSO
L<perlfunc/"stat">, L<MD5::Digest>, L<stat(2)>
Mention other useful documentation such as the documentation of
related modules or operating system documentation (such as man pages
in UNIX), or any relevant external documentation such as RFCs or
standards.
=head1 AUTHOR
Jeremy Madea, E<lt>jeremy@cpan.orgE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2003-2012 by Jeremy Madea. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut