File Coverage

blib/lib/Filesys/Restrict.pm
Criterion Covered Total %
statement 23 25 92.0
branch 3 6 50.0
condition 1 3 33.3
subroutine 7 7 100.0
pod 1 1 100.0
total 35 42 83.3


line stmt bran cond sub pod time code
1             package Filesys::Restrict;
2              
3 6     6   597785 use strict;
  6         81  
  6         181  
4 6     6   34 use warnings;
  6         21  
  6         376  
5              
6             our $VERSION;
7              
8             BEGIN {
9 6     6   21 $VERSION = '0.04';
10              
11 6         26 require XSLoader;
12 6         3121 XSLoader::load(__PACKAGE__, $VERSION);
13             }
14              
15             =encoding utf-8
16              
17             =head1 NAME
18              
19             Filesys::Restrict - Restrict filesystem access
20              
21             =head1 SYNOPSIS
22              
23             {
24             my $check = Filesys::Restrict::create(
25             sub {
26             my ($op, $path) = @_;
27              
28             return 1 if $path =~ m<^/safe/place/>;
29              
30             # Deny access to anything else:
31             return 0;
32             },
33             );
34              
35             # In this block, most Perl code will throw if it tries
36             # to access anything outside of /safe/place.
37             }
38              
39             # No more filesystem checks here.
40              
41             =head1 DESCRIPTION
42              
43             This module is a reasonable-best-effort at preventing Perl code from
44             accessing files you don’t want to allow. One potential application of
45             this is to restrict filesystem access to F in tests.
46              
47             =head1 B B B B B B
48              
49             This module cannot prevent all unintended filesystem access.
50             The following are some known ways to circumvent it:
51              
52             =over
53              
54             =item * Use XS modules (e.g., L).
55              
56             =item * Use one of C’s more esoteric forms.
57             This module tries to parse typical C arguments but doesn’t
58             “bend over backward”. The 2- and 3-argument forms are assumed to be
59             valid if there’s an unrecognized format, and we ignore the 1-argument
60             form entirely.
61              
62             =item * Call C, C, or C.
63              
64             We I actually restrict C and C.
65             These, though, are a bit different from other built-ins because they
66             don’t facilitate reading arbitrary data off the filesystem; rather,
67             they’re narrowly-scoped to bringing in additional Perl code.
68              
69             If you have a use case where it’s useful to restrict these,
70             file a feature request.
71              
72             =back
73              
74             =head1 SEE ALSO
75              
76             L can achieve a similar effect to this module but
77             has some compatibility problems with some Perl syntax.
78              
79             Linux’s L provides a method of real-time access control
80             via the kernel. See L and L for Perl
81             implementations.
82              
83             =cut
84              
85             #----------------------------------------------------------------------
86              
87 6     6   2419 use Filesys::Restrict::X ();
  6         16  
  6         1260  
88              
89             our $_AUTHORIZE = undef;
90              
91             #----------------------------------------------------------------------
92              
93             =head1 FUNCTIONS
94              
95             =head2 $obj = create( sub { .. } )
96              
97             Creates an opaque object that installs an access-control callback.
98             Any existing access-control callback is saved and restored whenever
99             $obj is DESTROYed.
100              
101             The access-control callback is called with two arguments:
102              
103             =over
104              
105             =item * The name of the Perl op that requests filesystem access.
106             The names come from C in Perl’s L header file;
107             they should correlate to the actual built-in called.
108              
109             =item * The filesystem path in question.
110              
111             =back
112              
113             The callback can end in one of three ways:
114              
115             =over
116              
117             =item * Return truthy to confirm access to the path.
118              
119             =item * Return falsy to cause a L
120             instance to be thrown.
121              
122             =item * Throw a custom exception.
123              
124             =back
125              
126             =cut
127              
128             sub create {
129 6 50   6 1 4187 die 'Void context is meaningless!' if !defined wantarray;
130              
131 6         21 my $cb = $_[0];
132              
133 6 50       22 if (!$cb) {
134 0         0 die( (caller 0)[3] . ' requires a callback!' );
135             }
136              
137 6 50 33     61 if (!ref($cb) || !UNIVERSAL::isa($cb, 'CODE')) {
138 0         0 die( (caller 0)[3] . " requires a callback, not “$cb”!" );
139             }
140              
141 6         16 my $stored_cb = $_AUTHORIZE;
142              
143 6         12 $_AUTHORIZE = $cb;
144              
145 6         37 return bless \$stored_cb, 'Filesys::Restrict::Guard';
146             }
147              
148             sub _CROAK {
149 57     57   98692 local $_AUTHORIZE;
150 57         270 die Filesys::Restrict::X->create('Forbidden', @_);
151             }
152              
153             #----------------------------------------------------------------------
154              
155             package Filesys::Restrict::Guard;
156              
157             sub DESTROY {
158 6     6   6462 $Filesys::Restrict::_AUTHORIZE = ${ $_[0] };
  6         84  
159             }
160              
161             1;
162              
163             #----------------------------------------------------------------------
164              
165             =head1 LICENSE & COPYRIGHT
166              
167             Copyright 2022 Gasper Software Consulting. All rights reserved.
168              
169             This library is licensed under the same terms as Perl itself.
170             See L.
171              
172             This library was originally a research project at
173             L.