File Coverage

blib/lib/Test/OnlySome/PathCapsule.pm
Criterion Covered Total %
statement 64 68 94.1
branch 15 28 53.5
condition 4 6 66.6
subroutine 14 16 87.5
pod 9 9 100.0
total 106 127 83.4


line stmt bran cond sub pod time code
1             #!perl
2              
3             # TODO see if I can replace this with Path::Class, Path::Extended,
4             # or Badger::Filesystem::Path.
5             package Test::OnlySome::PathCapsule;
6 41     41   3464850 use 5.012;
  41         475  
7 41     41   241 use strict;
  41         94  
  41         884  
8 41     41   198 use warnings;
  41         83  
  41         1184  
9 41     41   216 use Carp qw(croak);
  41         94  
  41         2337  
10 41     41   335 use File::Spec;
  41         97  
  41         1186  
11 41     41   230 use Cwd qw(cwd);
  41         108  
  41         2694  
12              
13 41     41   302 use constant { true => !!1, false => !!0 };
  41         94  
  41         34769  
14              
15             our $VERSION = '0.001003';
16              
17             # Docs {{{2
18              
19             =head1 NAME
20              
21             Test::OnlySome::PathCapsule - yet another object-oriented path representation
22              
23             =head1 INSTALLATION
24              
25             See L, with which this module is distributed.
26              
27             =head1 SYNOPSIS
28              
29             use Test::OnlySome::PathCapsule;
30             my $path = Test::OnlySome::PathCapsule->new('some/path')
31             my $cwd = Test::OnlySome::PathCapsule->new()
32              
33             $path->up() # move to the parent dir, if any
34             $path->down('foo') # move to dir 'foo'
35              
36             Test::OnlySome::PathCapsule doesn't care whether the path actually exists on disk.
37              
38             =head1 CREATING AND MODIFYING
39              
40             =cut
41              
42             # }}}2
43              
44             # new() # {{{1
45              
46             =head2 new
47              
48             Create a new instance.
49              
50             my $path = Test::OnlySome::PathCapsule->new([$pathname_string[, $is_dir = 0]])
51              
52             If C<$pathname_string> is given, the instance points at that path. Otherwise,
53             the instance points at cwd. If C<$is_dir>, C<$pathname_string> points at a
54             directory; otherwise, it points at a file.
55              
56             =cut
57              
58             sub new {
59 40     40 1 4687033 my $class = shift;
60 40         212 my $filename = shift;
61 40   100     414 my $is_dir = shift // false;
62 40         123978 my $cwd = cwd;
63              
64 40 100       949 unless(defined $filename) {
65 9         45 $filename = $cwd;
66 9         122 $is_dir = true;
67             }
68              
69 40 100       3481 $filename = File::Spec->rel2abs($filename, $cwd)
70             unless File::Spec->file_name_is_absolute($filename);
71              
72 40         2352 my ($vol, $dir, $file) = File::Spec->splitpath($filename, $is_dir);
73 40         600 $dir = File::Spec->catdir($dir);
74             # Trim trailing slash, if any
75              
76 40         976 my @dirs = File::Spec->splitdir($dir);
77              
78             # Note: hash keys all have a leading underscore to avoid name confusion
79             # with functions on the instance.
80 40         2489 return bless {
81             _vol => $vol, # The path itself, always stored absolute.
82             _dirs => [@dirs],
83             _file => $file,
84              
85             _is_dir => $is_dir, # The path's context
86             _relative_to => $cwd, # never changes
87             }, $class;
88             } # }}}1
89             # clone() # {{{1
90              
91             =head2 clone
92              
93             Return a clone of this instance. Useful if you want to start from one
94             path and move to others. Usage is C<$instance->clone()>.
95              
96             =cut
97              
98             sub clone {
99 6 50   6 1 80 my $self = shift or croak "Need an instance";
100             my $new_instance = {
101             _vol => $self->{_vol},
102 6         113 _dirs => [@{ $self->{_dirs} }], # One-level-deep copy
103             _file => $self->{_file},
104              
105             _is_dir => $self->{_is_dir},
106             _relative_to => $self->{_relative_to},
107 6         24 };
108              
109 6         52 return bless($new_instance, ref $self);
110             } # }}}1
111              
112             =head2 up
113              
114             Move up one directory, if that is possible. Returns the instance, so you can
115             chain calls. Usage:
116              
117             $path->up([$keep_filename=0])
118              
119             If C<$keep_filename> is truthy, keep the filename. Otherwise, clear it out,
120             since moving into a different directory probably invalidates the name.
121              
122             Returns the instance.
123              
124             =cut
125              
126             sub up {
127 16 50   16 1 246 my $self = shift or croak "Need an instance";
128 16   50     279 my $keep_filename = shift // false;
129 16         60 pop @{ $self->{_dirs} };
  16         68  
130 16 50       101 unless($keep_filename) {
131 16         73 $self->{_file} = '';
132 16         79 $self->{_is_dir} = true;
133             }
134 16         99 return $self;
135             } #up
136              
137             =head2 down
138              
139             Move up one directory, if that is possible. Returns the instance, so you can
140             chain calls. Usage:
141              
142             $path->down($whither[, $keep_filename=0])
143              
144             If C<$keep_filename> is truthy, keep the filename. Otherwise, clear it out,
145             since moving into a different directory probably invalidates the name.
146              
147             Returns the instance.
148              
149             =cut
150              
151             sub down {
152 18 50   18 1 96 my $self = shift or croak "Need an instance";
153 18 50       148 my $dir = shift or croak "Need a directory to move down to";
154 18   50     209 my $keep_filename = shift // false;
155              
156 18         52 push @{ $self->{_dirs} }, $dir;
  18         85  
157 18 50       61 unless($keep_filename) {
158 18         83 $self->{_file} = '';
159 18         55 $self->{_is_dir} = true;
160             }
161 18         163 return $self;
162             } #down
163              
164             =head2 file
165              
166             Get or set the filename. Usage:
167              
168             $self->file([$new_filename])
169              
170             If no argument is given, returns the current filename, or C if the
171             path is a directory. If an argument is given, marks the instance as not
172             representing a dir, and returns the instance.
173              
174             =cut
175              
176             sub file {
177 30 50   30 1 226 my $self = shift or croak "Need an instance";
178              
179 30 100       174 if(@_) { # Setter
180 26         176 $self->{_file} = '' . shift;
181 26         101 $self->{_is_dir} = false;
182 26         298 return $self;
183             } else { # Getter
184 4         46 return $self->{_file};
185             }
186             } #file
187              
188             =head1 ACCESSING
189              
190             =head2 is_dir
191              
192             Returns true if the instance represents a directory as opposed to a file.
193              
194             =cut
195              
196             sub is_dir {
197 5 50   5 1 2486 my $self = shift or croak "Need an instance";
198 5         80 return !!$self->{_is_dir};
199             } #is_dir()
200              
201             =head2 abs
202              
203             Returns the absolute path to the file. Usage: C<$self->abs>.
204              
205             =cut
206              
207             sub abs {
208 49 50   49 1 4577 my $self = shift or croak "Need an instance";
209             return File::Spec->catpath($self->{_vol},
210 49         7049 File::Spec->catdir(@{ $self->{_dirs} }),
211 49         181 $self->{_file});
212             } #abs()
213              
214             =head2 rel
215              
216             Returns the relative path to the file from the current working directory.
217             Usage: C<$self->rel>.
218              
219             =cut
220              
221             sub rel {
222 0 0   0 1   my $self = shift or croak "Need an instance";
223 0           return File::Spec->abs2rel($self->abs, cwd);
224             } #rel()
225              
226             =head2 rel_orig
227              
228             Returns the relative path to the file from the current working directory
229             at the time the instance was created. Usage: C<$self->rel_orig>.
230              
231             =cut
232              
233             sub rel_orig {
234 0 0   0 1   my $self = shift or croak "Need an instance";
235 0           return File::Spec->abs2rel($self->abs, $self->{_relative_to});
236             } #rel_orig()
237              
238             1;
239             # vi: set fdm=marker fo-=ro: