File Coverage

blib/lib/Sendmail/Queue/Df.pm
Criterion Covered Total %
statement 64 81 79.0
branch 22 36 61.1
condition 1 3 33.3
subroutine 13 14 92.8
pod 6 6 100.0
total 106 140 75.7


line stmt bran cond sub pod time code
1             package Sendmail::Queue::Df;
2 1     1   188734 use strict;
  1         2  
  1         41  
3 1     1   6 use warnings;
  1         1  
  1         35  
4 1     1   7 use Carp;
  1         2  
  1         65  
5              
6 1     1   6 use File::Spec;
  1         10  
  1         21  
7 1     1   1175 use IO::File;
  1         1241  
  1         228  
8 1     1   8 use Fcntl qw( :flock );
  1         2  
  1         238  
9              
10 1     1   7 use Scalar::Util qw( blessed );
  1         2  
  1         164  
11              
12 1     1   645 use Sendmail::Queue::Base;
  1         2  
  1         901  
13             our @ISA = qw( Sendmail::Queue::Base );
14             __PACKAGE__->make_accessors( qw(
15             queue_id
16             queue_directory
17             data
18             hardlinked
19             ) );
20              
21             =head1 NAME
22              
23             Sendmail::Queue::Df - Represent a Sendmail dfXXXXXX (data) file
24              
25             =head1 SYNOPSIS
26              
27             use Sendmail::Queue::Df
28              
29             # Create a new df file object
30             my $df = Sendmail::Queue::Df->new();
31              
32             # Give it an ID
33             $df->set_queue_id( $some_qf->get_queue_id );
34              
35             # Give it some data directly
36             $df->set_data( $scalar_with_body );
37              
38             # ... or, give some data from a filehandle
39             $df->set_data_from( $some_fh );
40              
41             # ... or, hardlink it to another object, or to a pathname
42             $df->hardlink_to( $other_df );
43             $df->hardlink_to( '/path/to/file' );
44              
45             # Make sure it's on disk.
46             $df->write( '/path/to/queue');
47              
48             =head1 DESCRIPTION
49              
50             Sendmail::Queue::Df provides a representation of a Sendmail df (data) file.
51              
52             =head1 METHODS
53              
54             =head2 new ( \%args )
55              
56             Create a new Sendmail::Queue::Df object.
57              
58             =cut
59              
60             sub new
61             {
62 5     5 1 5523 my ($class, $args) = @_;
63              
64 5 50       62 my $self = {
65             queue_directory => undef,
66             queue_id => undef,
67             data => undef,
68             hardlinked => 0,
69              
70 5         13 %{ $args || {} }
71             };
72              
73 5         18 bless $self, $class;
74              
75 5         17 return $self;
76             }
77              
78             =head2 hardlink_to ( $target )
79              
80             Instead of writing a new data file, hardlink this one to an existing file.
81              
82             $target can be either a L object, or a scalar pathname.
83              
84             =cut
85              
86             sub hardlink_to
87             {
88 1     1 1 155 my ($self, $target) = @_;
89              
90 1         2 my $target_path = $target;
91              
92 1 50 33     7 if( ref $target && blessed $target eq 'Sendmail::Queue::Df' ) {
93 0         0 $target_path = $target->get_data_filename();
94             }
95              
96 1 50       41 if( ! -f $target_path ) {
97 0         0 die qq{Path $target_path does not exist};
98             }
99              
100 1 50       6 if( ! $self->get_data_filename ) {
101 0         0 die q{Current object has no path to hardlink!}
102             }
103              
104 1 50       7 if( ! link $target_path, $self->get_data_filename ) {
105 0         0 die qq{Hard link failed: $!};
106             }
107              
108 1         4 $self->{hardlinked} = 1;
109              
110 1         4 return 1;
111             }
112              
113             =head2 get_data_filename
114              
115             Return the full path name of this data file.
116              
117             Will return undef if no queue ID exists, and die if queue directory is
118             unset.
119              
120             =cut
121              
122             sub get_data_filename
123             {
124 16     16 1 725 my ($self) = @_;
125              
126 16 50       52 if( ! $self->get_queue_directory ) {
127 0         0 die q{queue directory not set};
128             }
129              
130 16 100       48 if( ! $self->get_queue_id ) {
131 2         12 return undef;
132             }
133              
134 14         39 return File::Spec->catfile( $self->get_queue_directory(), 'df' . $self->get_queue_id() );
135             }
136              
137             =head2 set_data_from ( $data_fh )
138              
139             Given a filehandle, read the data from it, up to the end of file, and
140             store it in the object.
141              
142             =cut
143              
144             sub set_data_from
145             {
146 0     0 1 0 my ($self, $data_fh) = @_;
147              
148 0         0 $self->set_data( do { local $/; <$data_fh> } );
  0         0  
  0         0  
149             }
150              
151             =head2 write ( )
152              
153             Write data to df file, if necessary.
154              
155             =cut
156              
157             sub write
158             {
159 3     3 1 9 my ($self) = @_;
160              
161 3 100       12 if ( $self->{hardlinked} ) {
162 1         3 return undef;
163             }
164              
165 2 50       8 if ( ! $self->get_queue_directory ) {
166 0         0 die q{write() requires a queue directory};
167             }
168              
169 2 50       7 if( ! $self->get_queue_id() ) {
170 0         0 die q{no queue id!}
171             }
172              
173 2         7 my $filepath = $self->get_data_filename();
174              
175 2 50       100 if( -e $filepath ) {
176 0         0 die qq{File $filepath already exists; write() doesn't know how to overwrite yet};
177             }
178              
179 2         14 my $old_umask = umask(002);
180 2         21 my $fh = IO::File->new( $filepath, O_WRONLY|O_CREAT|O_EXCL );
181 2         834 umask($old_umask);
182 2 50       8 if( ! $fh ) {
183 0         0 die qq{File $filepath could not be created: $!};
184             }
185              
186 2 50       11 if( ! $fh->print( $self->get_data ) ) {
187 0         0 die qq{Couldn't print to $filepath: $!};
188             }
189              
190 2 50       249 if( ! $fh->flush ) {
191 0         0 die qq{Couldn't flush $filepath: $!};
192             }
193              
194 2 50       56516 if( ! $fh->sync ) {
195 0         0 die qq{Couldn't sync $filepath: $!};
196             }
197              
198 2 50       54 if( ! $fh->close ) {
199 0         0 die qq{Couldn't close $filepath: $!};
200             }
201              
202 2         110 return 1;
203             }
204              
205             =head2 unlink ( )
206              
207             Unlink the queue file. Returns true (1) on success, false (undef) on
208             failure.
209              
210             Unlinking the queue file will only succeed if we have a queue directory
211             and queue ID configured for this object. Otherwise, we fail to delete.
212              
213             =cut
214              
215             sub unlink
216             {
217 3     3 1 6 my ($self) = @_;
218              
219 3 100       10 if( ! $self->get_data_filename ) {
220             # No filename, can't unlink
221 1         5 return 0;
222             }
223              
224 2 100       16 if( 1 != unlink($self->get_data_filename) ) {
225 1         14 return 0;
226             }
227              
228 1         6 return 1;
229             }
230              
231             1;
232             __END__