File Coverage

blib/lib/Filesys/Virtual/Chroot.pm
Criterion Covered Total %
statement 49 97 50.5
branch 17 66 25.7
condition 4 33 12.1
subroutine 11 14 78.5
pod 10 10 100.0
total 91 220 41.3


line stmt bran cond sub pod time code
1             package Filesys::Virtual::Chroot;
2             #
3             # Copyright (C) 2014 Colin Faber
4             #
5             # This program is free software: you can redistribute it and/or modify
6             # it under the terms of the GNU General Public License as published by
7             # the Free Software Foundation version 2 of the License.
8             #
9             # This program is distributed in the hope that it will be useful,
10             # but WITHOUT ANY WARRANTY; without even the implied warranty of
11             # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12             # GNU General Public License for more details.
13             #
14             # You should have received a copy of the GNU General Public License
15             # along with this program. If not, see .
16             #
17             #
18             # Original author: Colin Faber
19             # Original creation date: 11/12/2015
20             # Version: $Id: Chroot.pm,v 1.4 2015/11/14 23:27:34 cfaber Exp $
21             #
22              
23             # Version change
24             our $VERSION = $1 if('$Revision: 1.4 $' =~ /([\d.]+)/);
25              
26 3     3   69339 use strict;
  3         6  
  3         78  
27 3     3   14 use warnings;
  3         7  
  3         97  
28 3     3   14 use Cwd;
  3         8  
  3         5534  
29              
30             =head1 NAME
31              
32             Filesys::Virtual::Chroot - Virtual File system Tool
33              
34             =head1 DESCRIPTION
35              
36             Provide a virtual chroot environment. This module only simulates a
37             chroot environment and only provides a advisory functions for your
38             application. This module is B intended to provide application
39             security!!!
40              
41              
42             =head1 SYNOPSIS
43              
44             #!/usr/bin/perl
45             use strict;
46             use Filesys::Virtual::Chroot;
47              
48             my $cr = Filesys::Virtual::Chroot->new(
49             c => '/tmp',
50             i => 0
51             ) || die $Filesys::Virtual::Chroot::errstr;
52              
53             print " Root: " . $cr->rroot . "\n";
54             print " Fake: " . $cr->vpwd . "\n";
55              
56             if($cr->vchdir($ARGV[0])){
57             print " Change directory success\r\n";
58             print " Root: " . $cr->rroot . "\n";
59             print " Real: " . $cr->rcwd . "\n";
60             print " Fake: " . $cr->vcwd . "\n";
61             } else {
62             print $cr->errstr . "\n";
63             }
64              
65             exit;
66              
67             =head1 METHODS
68              
69             =head2 new( %Options )
70              
71             Create a new Filesys::Virtual::Chroot object.
72              
73             =head3 Options
74              
75             chroot - The full path of the directory which will be virtual chroot'd
76              
77             c - Same as chroot
78              
79             no_force_case - Don't force case matching, Turn this on, on windows machines.
80              
81             i - Same as no_force_case
82              
83             =head3 Error handling
84              
85             If something happens which results in an error, nothing will be returned and the Filesys::Virtual::Chroot::errstr will be set with the error message.
86              
87             =cut
88              
89             sub new {
90 2     2 1 1347 my ($class, %o) = @_;
91             my $self = bless {
92             i => (defined $o{i} ? $o{i} : $o{force_case}),
93             c => (defined $o{c} ? $o{c} : $o{chroot})
94 2 50       19 }, __PACKAGE__;
    50          
95              
96 2 50       69 if(!defined $self->{c}){
    50          
    50          
97 0         0 return &_se('The (c or chroot) option is required and MUST be a valid directory path');
98             } elsif(-l $self->{c}){
99 0         0 return &_se('The (c or chroot) option may not be a symbolic link: ' . $self->{c});
100             } elsif(!-d $self->{c}){
101 0         0 return &_se('Unable to read the (c or chroot) directory path: ' . $self->{c} . " $!");
102             } else {
103 2 50       7699 my $current = $1 if(Cwd::cwd() =~ /(.+)/s);
104              
105             # Figure out the virtual root
106 2 50       166 chdir($self->{c}) || return &_se("chdir() to: $self->{c} failed: $!");
107              
108 2         7611 $self->{rr} = Cwd::cwd();
109              
110             # Slice the trailing slash
111 2         40 $self->{rr} =~ s|/$||g;
112              
113             # Return the current working directory
114 2 50       90 chdir($current) || return &_se("chdir() unable to return to working directory: $current $!");
115             }
116              
117              
118 2         105 return $self;
119             }
120              
121             =head2 errstr()
122              
123             Return the last error message captured.
124              
125             =cut
126              
127             sub errstr {
128 0     0 1 0 my ($self, $err) = @_;
129 0 0       0 $self->{'.e'} = $err if $err;
130 0         0 return $self->{'.e'};
131             }
132              
133             # internal routine for error handling.
134             sub _se {
135 0     0   0 my ($self, $err) = @_;
136 0 0       0 if(ref($self) ne 'Filesys::Virtual::Chroot'){
137 0         0 $Filesys::Virtual::Chroot::errstr = $self;
138             } else {
139 0         0 $self->errstr($err);
140             }
141              
142 0         0 return;
143             }
144              
145             =head2 rroot()
146              
147             Return the real full root path of the virtual chroot'd environment.
148              
149             =cut
150              
151             sub rroot {
152             return $_[0]->{rr}
153 4     4 1 23 }
154              
155              
156             =head2 lchdir()
157              
158             Return the last real directory that was changed to with $cr->vchdir()
159              
160             =cut
161              
162             sub lchdir {
163 3     3 1 11 my ($self, $str) = @_;
164              
165 3 100       23 $self->{lpath} = $str if $str;
166              
167 3         70 return $self->{lpath};
168             }
169              
170              
171             =head2 vchdir(path)
172              
173             Change the virtual directory and return the virtual directory that was changed to.
174              
175             =cut
176              
177             sub vchdir {
178 1     1 1 5 my ($self, $path) = @_;
179              
180 1         3 my $proot = $self->rroot;
181              
182             # Clean up the entry
183 1 50       17 $path =~ s/^\s+|\s+$//g if $path;
184              
185 1         11 $proot =~ s/(\W)/\\$1/g;
186              
187 1         7 my $lpath;
188 1 50 33     21 if($path && $path !~ /^\//){
189 0         0 $lpath = '/' . $path;
190             } else {
191 1         3 $lpath = $path;
192             }
193              
194 1 50       11 if($path){
195 1         4 $path = $self->rroot . '/' . $path;
196             } else {
197 0         0 $path = $self->rroot;
198             }
199              
200             # Remove any duplicate slashes in the path. i.e. /root//some////path/////
201 1         8 $path =~ s/\/+/\//g;
202              
203 1         3 $path =~ /(.+)/s;
204              
205 1         3241 my $current = Cwd::cwd();
206              
207 1 50       42 chdir($1) || return $self->_se("Unable to chdir() to: ($1) $lpath $!");
208              
209 1         3016 $self->lchdir( Cwd::cwd() );
210              
211 1 50 33     6 if(($self->lchdir !~ /^$proot.*?/ && !$self->{i}) || ($self->lchdir !~ /^$proot.*?/i && $self->{i})){
      33        
      33        
212              
213 0 0       0 chdir($current) || return &_se("chdir() unable to return to working directory: $current $!");
214 0         0 return $self->_se('chdir failed: directory below root!');
215             } else {
216 1         2921 my $spath = Cwd::cwd();
217              
218 1         33 $spath =~ s/$proot//g;
219              
220 1 50       43 return ($spath ? $spath : '/');
221             }
222             }
223              
224              
225             =head2 rpath(file)
226              
227             Return the real full path of if is within the virtual chroot environment
228              
229             =cut
230              
231             sub rpath {
232 0     0 1 0 my ($self, $obj) = @_;
233              
234 0         0 my $proot = $self->rroot;
235              
236             # Grab the file / directory we're checking
237 0         0 my @p = split(/\//, $obj);
238              
239 0         0 $obj = pop @p;
240              
241 0         0 my $path = join('/', @p);
242              
243             # Clean up the entry
244 0 0       0 if($path){
245 0         0 $path =~ s/^\s+|\s+$//g;
246 0 0       0 $path =~ s/\/+/\//g if $path;
247             }
248              
249             # If the request is below the root and the path is the root
250             # return information on the root.
251 0 0 0     0 if(!defined $obj || ($obj eq '..' && defined $path && $path eq '/')){
      0        
      0        
252 0         0 return $proot;
253             }
254              
255 0         0 $proot =~ s/(\W)/\\$1/g;
256              
257 0         0 my $lpath;
258 0 0 0     0 if($path && $path !~ /^\//){
259 0         0 $lpath = '/' . $path;
260             } else {
261 0         0 $lpath = $path;
262             }
263              
264 0 0       0 if($path){
265 0         0 $path = $self->rroot . '/' . $path;
266             } else {
267 0         0 $path = $self->rroot;
268             }
269              
270             # Remove any duplicate slashes in the path. i.e. /root//some////path/////
271 0         0 $path =~ s/\/+/\//g;
272              
273 0 0       0 my $current = $1 if(Cwd::cwd() =~ /(.+)/s);
274              
275 0         0 $path =~ /(.+)/s;
276              
277 0 0       0 if(!chdir($1)){
278 0         0 my $err = $!;
279 0         0 return $self->_se("Unable to chdir() to: [$1] $lpath $err. While verifying $obj");
280             }
281              
282 0         0 $self->lchdir( Cwd::cwd() );
283              
284 0 0 0     0 if(($self->lchdir !~ /^$proot.*?/ && !$self->{i}) || ($self->lchdir !~ /^$proot.*?/i && $self->{i})){
      0        
      0        
285 0 0       0 chdir($current) || return &_se("chdir() unable to return to working directory: $current $!");
286 0         0 return $self->_se('chdir failed: directory below root!');
287             } else {
288 0 0       0 my $r = ($self->rcwd ?
    0          
    0          
289             ($obj ? $self->rcwd . '/' . $obj : $self->rcwd) :
290             ($obj ? '/' . $obj : '/')
291             );
292              
293 0 0       0 chdir($current) || return &_se("chdir() unable to return to working directory: $current $!");
294 0         0 return $r;
295             }
296             }
297              
298             =head2 vcwd()
299              
300             Return the virtual current working directory
301              
302             =cut
303              
304             sub vcwd {
305 1     1 1 3 my ($self) = @_;
306              
307 1         3761 my $cwd = Cwd::cwd();
308              
309 1         21 my $proot = $self->rroot;
310              
311 1         29 $proot =~ s/(\W)/\\$1/g;
312              
313 1 50       37 if(!($cwd =~ s/$proot//g)){
314 1         31 return '/';
315             }
316              
317 0         0 $cwd =~ s|/+|/|g;
318              
319 0 0       0 return ($cwd ? $cwd : '/');
320             }
321              
322              
323             =head2 vpwd(path)
324              
325             aliase for the vcwd() command.
326              
327             =cut
328              
329             sub vpwd {
330 1     1 1 5 Filesys::Virtual::Chroot::vcwd(@_);
331             }
332              
333              
334             =head2 rcwd()
335              
336             Return the real current working directory
337              
338             =cut
339              
340 1     1 1 3014 sub rcwd { Cwd::cwd() }
341              
342              
343             =head2 rpwd()
344              
345             aliase for the rcwd() command.
346              
347             =cut
348              
349             sub rpwd {
350 1     1 1 9 Filesys::Virtual::Chroot::rcwd(@_);
351             }
352              
353             1;