File Coverage

lib/DBI/Filesystem.pm
Criterion Covered Total %
statement 10 12 83.3
branch n/a
condition n/a
subroutine 4 4 100.0
pod n/a
total 14 16 87.5


line stmt bran cond sub pod time code
1             package DBI::Filesystem;
2              
3             =head1 NAME
4              
5             DBI::Filesystem - Store a filesystem in a relational database
6              
7             =head1 SYNOPSIS
8              
9             use DBI::Filesystem;
10              
11             # Preliminaries. Create the mount point:
12             mkdir '/tmp/mount';
13              
14             # Create the databas:
15             system "mysqladmin -uroot create test_filesystem";
16             system "mysql -uroot -e 'grant all privileges on test_filesystem.* to $ENV{USER}@localhost' mysql";
17              
18             # (Usually you would do this in the shell.)
19             # (You will probably need to add the admin user's password)
20              
21             # Create the filesystem object
22             $fs = DBI::Filesystem->new('dbi:mysql:test_filesystem',{initialize=>1});
23              
24             # Mount it on the mount point.
25             # This call will block until the filesystem is mounted by another
26             # process by calling "fusermount -u /tmp/mount"
27             $fs->mount('/tmp/mount');
28              
29             # Alternatively, manipulate the filesystem directly from within Perl.
30             # Any of these methods could raise a fatal error, so always wrap in
31             # an eval to catch those errors.
32             eval {
33             # directory creation
34             $fs->create_directory('/dir1');
35             $fs->create_directory('/dir1/subdir_1a');
36              
37             # file creation
38             $fs->create_file('/dir1/subdir_1a/test.txt');
39              
40             # file I/O
41             $fs->write('/dir1/subdir_1a/test.txt','This is my favorite file',0);
42             my $data = $fs->read('/dir1/subdir_1a/test.txt',100,0);
43              
44             # reading contents of a directory
45             my @entries = $fs->getdir('/dir1');
46              
47             # fstat file/directory
48             my @stat = $fs->stat('/dir1/subdir_1a/test.txt');
49              
50             #chmod/chown file
51             $fs->chmod('/dir1/subdir_1a/test.txt',0600);
52             $fs->chown('/dir1/subdir_1a/test.txt',1001,1001); #uid,gid
53              
54             # rename file/directory
55             $fs->rename('/dir1'=>'/dir2');
56              
57             # create a symbolic link
58             $fs->symlink('/dir2' => '/dir1');
59              
60             # create a hard link
61             $fs->link('/dir2/subdir_1a/test.txt' => '/dir2/hardlink.txt');
62              
63             # read symbolic link
64             my $target = $fs->read_symlink('/dir1/symlink.txt');
65              
66             # unlink a file
67             $fs->unlink_file('/dir2/subdir_1a/test.txt');
68              
69             # remove a directory
70             $fs->remove_directory('/dir2/subdir_1a');
71              
72             # get the inode (integer) that corresponds to a file/directory
73             my $inode = $fs->path2inode('/dir2');
74              
75             # get the path(s) that correspond to an inode
76             my @paths = $fs->inode2paths($inode);
77             };
78             if ($@) { warn "file operation failed with $@"; }
79            
80             =head1 DESCRIPTION
81              
82             This module can be used to create a fully-functioning "Fuse" userspace
83             filesystem on top of a relational database. Unlike other
84             filesystem-to-DBM mappings, such as Fuse::DBI, this one creates and
85             manages a specific schema designed to support filesystem
86             operations. If you wish to mount a filesystem on an arbitrary DBM
87             schema, you probably want Fuse::DBI, not this.
88              
89             Most filesystem functionality is implemented, including hard and soft
90             links, sparse files, ownership and access modes, UNIX permission
91             checking and random access to binary files. Very large files (up to
92             multiple gigabytes) are supported without performance degradation.
93              
94             Why would you use this? The main reason is that it allows you to use
95             DBMs functionality such as accessibility over the network, database
96             replication, failover, etc. In addition, the underlying
97             DBI::Filesystem module can be extended via subclassing to allow
98             additional functionality such as arbitrary access control rules,
99             searchable file and directory metadata, full-text indexing of file
100             contents, etc.
101              
102             Before mounting the DBMS, you must have created the database and
103             assigned yourself sufficient privileges to read and write to it. You
104             must also create an empty directory to serve as the mount point.
105              
106             A convenient front-end to this library is provided by B,
107             which is installed along with this library.
108              
109             =head2 Unsupported Features
110              
111             The following features are not implemented:
112              
113             * statfs -- df on the filesystem will not provide any useful information
114             on free space or other filesystem information.
115              
116             * extended attributes -- Extended attributes are not supported.
117              
118             * nanosecond times -- atime, mtime and ctime are accurate only to the
119             second.
120              
121             * ioctl -- none are supported
122              
123             * poll -- polling on the filesystem to detect file update events will not work.
124              
125             * lock -- file handle locking among processes running on the local machine
126             works, but protocol-level locking, which would allow cooperative
127             locks on different machines talking to the same database server,
128             is not implemented.
129              
130             You must be the superuser in order to create a file system with the
131             suid and dev features enabled, and must invoke this commmand with
132             the mount options "allow_other", "suid" and/or "dev":
133              
134             -o dev,suid,allow_other
135              
136             =head2 Supported Database Management Systems
137              
138             DBMSs differ in what subsets of the SQL language they support,
139             supported datatypes, date/time handling, and support for large binary
140             objects. DBI::Filesystem currently supports MySQL, PostgreSQL and
141             SQLite. Other DBMSs can be supported by creating a subclass file
142             named, e.g. DBI::Filesystem:Oracle, where the last part of the class
143             name corresponds to the DBD driver name ("Oracle" in this
144             example). See DBI::Filesystem::SQLite, DBI::Filesystem::mysql and
145             DBI::Filesystem:Pg for an illustration of the methods that need to be
146             defined/overridden.
147              
148             =head2 Fuse Installation Notes
149              
150             For best performance, you will need to run this filesystem using a
151             version of Perl that supports IThreads. Otherwise it will fall back to
152             non-threaded mode, which will introduce occasional delays during
153             directory listings and have notably slower performance when reading
154             from more than one file simultaneously.
155              
156             If you are running Perl 5.14 or higher, you *MUST* use at least 0.15
157             of the Perl Fuse module. At the time this was written, the version of
158             Fuse 0.15 on CPAN was failing its regression tests on many
159             platforms. I have found that the easiest way to get a fully
160             operational Fuse module is to clone and compile a patched version of
161             the source, following this recipe:
162              
163             $ git clone git://github.com/dpavlin/perl-fuse.git
164             $ cd perl-fuse
165             $ perl Makefile.PL
166             $ make test (optional)
167             $ sudo make install
168              
169             =head1 HIGH LEVEL METHODS
170              
171             The following methods are most likely to be needed by users of this module.
172              
173             =cut
174              
175 5     5   18828 use strict;
  5         14  
  5         197  
176 5     5   25 use warnings;
  5         9  
  5         153  
177 5     5   31 use DBI;
  5         9  
  5         262  
178 5     5   2244 use Fuse 'fuse_get_context',':xattr';
  0            
  0            
179             use threads;
180             use threads::shared;
181             use File::Basename 'basename','dirname';
182             use File::Spec;
183             use POSIX qw(ENOENT EISDIR ENOTDIR ENOTEMPTY EINVAL ECONNABORTED EACCES EIO EPERM EEXIST
184             O_RDONLY O_WRONLY O_RDWR O_CREAT F_OK R_OK W_OK X_OK
185             S_IXUSR S_IXGRP S_IXOTH);
186             use Carp 'croak';
187              
188             our $VERSION = '1.04';
189              
190             use constant SCHEMA_VERSION => 3;
191             use constant ENOATTR => ENOENT; # not sure this is right?
192             use constant MAX_PATH_LEN => 4096; # characters
193             use constant BLOCKSIZE => 16384; # bytes
194             use constant FLUSHBLOCKS => 256; # flush after we've accumulated this many cached blocks
195              
196             my %Blockbuff :shared;
197              
198              
199             =head2 $fs = DBI::Filesystem->new($dsn,{options...})
200              
201             Create the new DBI::Filesystem object. The mandatory first argument is
202             a DBI data source, in the format "dbi::". The
203             other arguments may include the database name, host, port, and
204             security credentials. See the documentation for your DBMS for details.
205              
206             Non-mandatory options are contained in a hash reference with one or
207             more of the following keys:
208              
209             initialize If true, then initialize the database schema. Many
210             DBMSs require you to create the database first.
211              
212             ignore_permissions If true, then Unix permission checking is not
213             performed when creating/reading/writing files.
214              
215             allow_magic_dirs If true, allow SQL statements in "magic" directories
216             to be executed (see below).
217              
218             WARNING: Initializing the schema quietly destroys anything that might
219             have been there before!
220              
221             =cut
222              
223             # DBI::Filesystem->new($dsn,{create=>1,ignore_permissions=>1})
224             sub new {
225             my $class = shift;
226             my ($dsn,$options) = @_;
227              
228             my ($dbd) = $dsn =~ /dbi:([^:]+)/;
229             $dbd or croak "Could not figure out the DBI subclass to load from $dsn";
230              
231             $options ||= {};
232              
233             # load the appropriate DBD subclass and fix up its @ISA so that we become
234             # the parent class
235             my $c = ref $class||$class;
236             my $subclass = __PACKAGE__.'::DBD::'.$dbd;
237             eval "require $subclass;1" or croak $@ unless $subclass->can('new');
238             eval "unshift \@$subclass\:\:ISA,'$c' unless \$subclass->isa('$c')";
239             die $@ if $@;
240              
241             my $self = bless {
242             dsn => $dsn,
243             %$options
244             },$subclass;
245              
246             local $self->{dbh}; # to avoid cloning database handle into child threads
247              
248             $self->initialize_schema if $options->{initialize};
249             $self->check_schema_version;
250             return $self;
251             }
252              
253             =head2 $boolean = $fs->ignore_permissions([$boolean]);
254              
255             Get/set the ignore_permissions flag. If ignore_permissions is true,
256             then all permission checks on file and directory access modes are
257             disabled, allowing you to create files owned by root, etc.
258              
259             =cut
260              
261             sub ignore_permissions {
262             my $self = shift;
263             my $d = $self->{ignore_permissions};
264             $self->{ignore_permissions} = shift if @_;
265             $d;
266             }
267              
268             =head2 $boolean = $fs->allow_magic_dirs([$boolean]);
269              
270             Get/set the allow_magic_dirs flag. If true, then directories whose
271             names begin with "%%" will be searched for a dotfile named ".query"
272             that contains a SQL statement to be run every time a directory listing
273             is required from this directory. See getdir() below.
274              
275             =cut
276              
277             sub allow_magic_dirs {
278             my $self = shift;
279             my $d = $self->{allow_magic_dirs};
280             $self->{allow_magic_dirs} = shift if @_;
281             $d;
282             }
283              
284             ############### filesystem handlers below #####################
285              
286             our $Self; # because entrypoints cannot be passed as closures
287              
288             =head2 $fs->mount($mountpoint, [\%fuseopts])
289              
290             This method will mount the filesystem on the indicated mountpoint
291             using Fuse and block until the filesystem is unmounted using the
292             "fusermount -u" command or equivalent. The mountpoint must be an empty
293             directory unless the "nonempty" mount option is passed.
294              
295             You may pass in a hashref of options to pass to the Fuse
296             module. Recognized options and their defaults are:
297              
298             debug Turn on verbose debugging of Fuse operations [false]
299             threaded Turn on threaded operations [true]
300             nullpath_ok Allow filehandles on open files to be used even after file
301             is unlinked [true]
302             mountopts Comma-separated list of mount options
303              
304             Mount options to be passed to Fuse are described at
305             http://manpages.ubuntu.com/manpages/precise/man8/mount.fuse.8.html. In
306             addition, you may pass the usual mount options such as "ro", etc. They
307             are presented as a comma-separated list as shown here:
308              
309             $fs->mount('/tmp/foo',{debug=>1,mountopts=>'ro,nonempty'})
310              
311             Common mount options include:
312              
313             Fuse specific
314             nonempty Allow mounting over non-empty directories if true [false]
315             allow_other Allow other users to access the mounted filesystem [false]
316             fsname Set the filesystem source name shown in df and /etc/mtab
317             auto_cache Enable automatic flushing of data cache on open [false]
318             hard_remove Allow true unlinking of open files [true]
319             nohard_remove Activate alternate semantics for unlinking open files
320             (see below)
321              
322             General
323             ro Read-only filesystem
324             dev Allow device-special files
325             nodev Do not allow device-special files
326             suid Allow suid files
327             nosuid Do not allow suid files
328             exec Allow executable files
329             noexec Do not allow executable files
330             atime Update file/directory access times
331             noatime Do not update file/directory access times
332              
333             Some options require special privileges. In particular allow_other
334             must be enabled in /etc/fuse.conf, and the dev and suid options can
335             only be used by the root user.
336              
337             The "hard_remove" mount option is passed by default. This option
338             allows files to be unlinked in one process while another process holds
339             an open filehandle on them. The contents of the file will not actually
340             be deleted until the last open filehandle is closed. The downside of
341             this is that certain functions will fail when called on filehandles
342             connected to unlinked files, including fstat(), ftruncate(), chmod(),
343             and chown(). If this is an issue, then pass option
344             "nohard_remove". This will activate Fuse's alternative semantic in
345             which unlinked open files are renamed to a hidden file with a name
346             like ".fuse_hiddenXXXXXXX'. The hidden file is removed when the last
347             filehandle is closed.
348              
349             =cut
350              
351             sub mount {
352             my $self = shift;
353             my $mtpt = shift or croak "Usage: mount(\$mountpoint)";
354             my $fuse_opts = shift;
355              
356             $fuse_opts ||= {};
357              
358             my %mt_opts = map {$_=>1} split ',',($fuse_opts->{mountopts}||'');
359             $mt_opts{hard_remove}++ unless $mt_opts{nohard_remove};
360             delete $mt_opts{nohard_remove};
361             $fuse_opts->{mountopts} = join ',',keys %mt_opts;
362              
363             my $pkg = __PACKAGE__;
364              
365             $Self = $self; # because entrypoints cannot be passed as closures
366             $self->check_schema
367             or croak "This database does not appear to contain a valid schema. Do you need to initialize it?\n";
368             $self->mounted(1);
369             my @args = (
370             mountpoint => $mtpt,
371             getdir => "$pkg\:\:e_getdir",
372             getattr => "$pkg\:\:e_getattr",
373             fgetattr => "$pkg\:\:e_fgetattr",
374             open => "$pkg\:\:e_open",
375             release => "$pkg\:\:e_release",
376             flush => "$pkg\:\:e_flush",
377             read => "$pkg\:\:e_read",
378             write => "$pkg\:\:e_write",
379             ftruncate => "$pkg\:\:e_ftruncate",
380             truncate => "$pkg\:\:e_truncate",
381             create => "$pkg\:\:e_create",
382             mknod => "$pkg\:\:e_mknod",
383             mkdir => "$pkg\:\:e_mkdir",
384             rmdir => "$pkg\:\:e_rmdir",
385             link => "$pkg\:\:e_link",
386             rename => "$pkg\:\:e_rename",
387             access => "$pkg\:\:e_access",
388             chmod => "$pkg\:\:e_chmod",
389             chown => "$pkg\:\:e_chown",
390             symlink => "$pkg\:\:e_symlink",
391             readlink => "$pkg\:\:e_readlink",
392             unlink => "$pkg\:\:e_unlink",
393             utime => "$pkg\:\:e_utime",
394             getxattr => "$pkg\:\:e_getxattr",
395             listxattr => "$pkg\:\:e_listxattr",
396             nullpath_ok => 1,
397             debug => 0,
398             threaded => 1,
399             %$fuse_opts,
400             );
401             push @args,$self->_subclass_implemented_calls();
402             Fuse::main(@args);
403             }
404              
405             # this method detects when one of the currently unimplemented
406             # Fuse methods is defined in a subclass, and creates the appropriate
407             # Fuse stub to call it
408             sub _subclass_implemented_calls{
409             my $self = shift;
410             my @args;
411              
412             my @u = (qw(statfs fsync
413             setxattr getxattr listxattr removexattr
414             opendir readdir releasedir fsyncdir
415             init destroy lock utimens
416             bmap ioctl poll));
417             my @implemented = grep {$self->can($_)} @u;
418              
419             my $pkg = __PACKAGE__;
420             foreach my $method (@implemented) {
421             next if $self->can("e_$method"); # don't overwrite
422             my $hook = "$pkg\:\:e_$method";
423             eval <
424             sub $hook {
425             my \$path = fixup(shift) if \@_;
426             my \@result = eval {\$${pkg}\:\:Self->$method(\$path,\@_)};
427             return \$Self->errno(\$@) if \$@;
428             return wantarray ? \@result:\$result[0];
429             }
430             END
431             ;
432             warn $@ if $@;
433             push @args,($method => $hook);
434             }
435             return @args;
436             }
437              
438             =head2 $boolean = $fs->mounted([$boolean])
439              
440             This method returns true if the filesystem is currently
441             mounted. Subclasses can change this value by passing the new value as
442             the argument.
443              
444             =cut
445              
446             sub mounted {
447             my $self = shift;
448             my $d = $self->{mounted};
449             $self->{mounted} = shift if @_;
450             return $d;
451             }
452              
453             =head2 Fuse hook functions
454              
455             This module defines a series of short hook functions that form the
456             glue between Fuse's function-oriented callback hooks and this module's
457             object-oriented methods. A typical hook function looks like this:
458              
459             sub e_getdir {
460             my $path = fixup(shift);
461             my @entries = eval {$Self->getdir($path)};
462             return $Self->errno($@) if $@;
463             return (@entries,0);
464             }
465              
466             The preferred naming convention is that the Fuse callback is named
467             "getdir", the function hook is named e_getdir(), and the method is
468             $fs->getdir(). The DBI::Filesystem object is stored in a singleton
469             global named $Self. The hook fixes up the path it receives from Fuse,
470             and then calls the getdir() method in an eval{} block. If the getdir()
471             method raises an error such as "file not found", the error message is
472             passed to the errno() method to turn into a ERRNO code, and this is
473             returned to the caller. Otherwise, the hook returns the results in the
474             format proscribed by Fuse.
475              
476             If you are subclassing DBI::Filesystem, there is no need to define new
477             hook functions. All hooks described by Fuse are already defined or
478             generated dynamically as needed. Simply create a correctly-named
479             method in your subclass.
480              
481             These are the hooks that are defined:
482              
483             e_getdir e_open e_access e_unlink e_removexattr
484             e_getattr e_release e_rename e_rmdir
485             e_fgetattr e_flush e_chmod e_utime
486             e_mkdir e_read e_chown e_getxattr
487             e_mknod e_write e_symlink e_setxattr
488             e_create e_truncate e_readlink e_listxattr
489              
490             These hooks will be created as needed if a subclass implements the
491             corresponding methods:
492              
493             e_statfs e_lock e_init
494             e_fsync e_opendir e_destroy
495             e_readdir e_utimens
496             e_releasedir e_bmap
497             e_fsyncdir e_ioctl
498             e_poll
499              
500             =cut
501              
502             sub e_getdir {
503             my $path = fixup(shift);
504             my @entries = eval {$Self->getdir($path)};
505             return $Self->errno($@) if $@;
506             return (@entries,0);
507             }
508              
509             sub e_getattr {
510             my $path = fixup(shift);
511             my @stat = eval {$Self->getattr($path)};
512             return $Self->errno($@) if $@;
513             return @stat;
514             }
515              
516             # the {get,list}xattr methods call for a bit of finessing of return values
517             #
518             sub e_getxattr {
519             my $path = fixup(shift);
520             my $name = shift;
521             my $val = eval {$Self->getxattr($path,$name)};
522             return $Self->errno($@) if $@;
523             return 0 unless defined $val;
524             return $val
525             }
526              
527             sub e_listxattr {
528             my $path = fixup(shift);
529             my @val = eval {$Self->listxattr($path)};
530             return $Self->errno($@) if $@;
531             return (@val,0);
532             }
533              
534             sub e_fgetattr {
535             my ($path,$inode) = @_;
536             my @stat = eval {$Self->fgetattr(fixup($path),$inode)};
537             return $Self->errno($@) if $@;
538             return @stat;
539             }
540              
541             sub e_mkdir {
542             my $path = fixup(shift);
543             my $mode = shift;
544              
545             $mode |= 0040000;
546             my $ctx = $Self->get_context();
547             my $umask = $ctx->{umask};
548             eval {$Self->mkdir($path,$mode&(~$umask))};
549             return $Self->errno($@) if $@;
550             return 0;
551             }
552              
553             sub e_mknod {
554             my $path = fixup(shift);
555             my ($mode,$device) = @_;
556             my $ctx = $Self->get_context;
557             my $umask = $ctx->{umask};
558             eval {$Self->mknod($path,$mode&(~$umask),$device)};
559             return $Self->errno($@) if $@;
560             return 0;
561             }
562              
563             sub e_create {
564             my $path = fixup(shift);
565             my ($mode,$flags) = @_;
566             # warn sprintf("create(%s,0%o,0%o)",$path,$mode,$flags);
567             my $ctx = $Self->get_context;
568             my $umask = $ctx->{umask};
569             my $fh = eval {
570             $Self->mknod($path,$mode&(~$umask));
571             $Self->open($path,$flags,{});
572             };
573             return $Self->errno($@) if $@;
574             return (0,$fh);
575             }
576              
577             sub e_open {
578             my ($path,$flags,$info) = @_;
579             # warn sprintf("open(%s,0%o,%s)",$path,$flags,$info);
580             $path = fixup($path);
581             my $fh = eval {$Self->open($path,$flags,$info)};
582             return $Self->errno($@) if $@;
583             (0,$fh);
584             }
585              
586             sub e_release {
587             my ($path,$flags,$fh) = @_;
588             eval {$Self->release($fh)};
589             return $Self->errno($@) if $@;
590             return 0;
591             }
592              
593             sub e_flush {
594             my ($path,$fh) = @_;
595             eval {$Self->flush($path,$fh)};
596             return $Self->errno($@) if $@;
597             return 0;
598             }
599            
600              
601             sub e_read {
602             my ($path,$size,$offset,$fh) = @_;
603             $path = fixup($path);
604             my $data = eval {$Self->read($path,$size,$offset,$fh)};
605             return $Self->errno($@) if $@;
606             return $data;
607             }
608              
609             sub e_write {
610             my ($path,$buffer,$offset,$fh) = @_;
611             $path = fixup($path);
612             my $data = eval {$Self->write($path,$buffer,$offset,$fh)};
613             return $Self->errno($@) if $@;
614             return $data;
615             }
616              
617             sub e_truncate {
618             my ($path,$offset) = @_;
619             $path = fixup($path);
620             eval {$Self->truncate($path,$offset)};
621             return $Self->errno($@) if $@;
622             return 0;
623             }
624              
625             sub e_ftruncate {
626             my ($path,$offset,$inode) = @_;
627             $path = fixup($path);
628             eval {$Self->truncate($path,$offset,$inode)};
629             return $Self->errno($@) if $@;
630             return 0;
631             }
632              
633             sub e_link {
634             my ($oldname,$newname) = @_;
635             eval {$Self->link($oldname,$newname)};
636             return $Self->errno($@) if $@;
637             return 0;
638             }
639              
640             sub e_access {
641             my ($path,$access_mode) = @_;
642             eval {$Self->access($path,$access_mode)};
643             return $Self->errno($@) if $@;
644             return 0;
645             }
646              
647             sub e_rename {
648             my ($oldname,$newname) = @_;
649             eval { $Self->rename($oldname,$newname) };
650             return $Self->errno($@) if $@;
651             return 0;
652             }
653              
654             sub e_chmod {
655             my ($path,$mode) = @_;
656             eval {$Self->chmod($path,$mode)};
657             return $Self->errno($@) if $@;
658             return 0;
659             }
660              
661             sub e_chown {
662             my ($path,$uid,$gid) = @_;
663             eval {$Self->chown($path,$uid,$gid)};
664             return $Self->errno($@) if $@;
665             return 0;
666             }
667              
668             sub e_symlink {
669             my ($oldname,$newname) = @_;
670             eval {$Self->symlink($oldname,$newname)};
671             return $Self->errno($@) if $@;
672             return 0;
673             }
674              
675             sub e_readlink {
676             my $path = shift;
677             my $link = eval {$Self->readlink($path)};
678             return $Self->errno($@) if $@;
679             return $link;
680             }
681              
682             sub e_unlink {
683             my $path = shift;
684             eval {$Self->unlink($path)};
685             return $Self->errno($@) if $@;
686             return 0;
687             }
688              
689             sub e_rmdir {
690             my $path = shift;
691             eval {$Self->rmdir($path)};
692             return $Self->errno($@) if $@;
693             return 0;
694             }
695              
696             sub e_utime {
697             my ($path,$atime,$mtime) = @_;
698             $path = fixup($path);
699             my $result = eval {$Self->utime($path,$atime,$mtime)};
700             return $Self->errno($@) if $@;
701             return 0;
702             }
703              
704             =head2 $inode = $fs->mknod($path,$mode,$rdev)
705              
706             This method creates a file or special file (pipe, device file,
707             etc). The arguments are the path of the file to create, the mode of
708             the file, and the device number if creating a special device file, or
709             0 if not. The return value is the inode of the newly-created file, an
710             unique integer ID, which is actually the primary key of the metadata
711             table in the underlying database.
712              
713             The path in this, and all subsequent methods, is relative to the
714             mountpoint. For example, if the filesystem is mounted on /tmp/foobar,
715             and the file you wish to create is named /tmp/foobar/dir1/test.txt,
716             then pass "dir1/test.txt". You can also include a leading slash (as in
717             "/dir1/test.txt") which will simply be stripped off.
718              
719             The mode is a bitwise combination of file type and access mode as
720             described for the st_mode field in the stat(2) man page. If you
721             provide just the access mode (e.g. 0666), then the method will
722             automatically set the file type bits to indicate that this is a
723             regular file. You must provide the file type in the mode in order to
724             create a special file.
725              
726             The rdev field contains the major and minor device numbers for device
727             special files, and is only needed when creating a device special file
728             or pipe; ordinarily you can omit it. The rdev field is described in
729             stat(2).
730              
731             Various exceptions can arise during this call including invalid paths,
732             permission errors and the attempt to create a duplicate file
733             name. These will be presented as fatal errors which can be trapped by
734             an eval {}. See $fs->errno() for a list of potential error messages.
735              
736             Like other file-manipulation methods, this will die with a "permission
737             denied" message if the current user does not have sufficient
738             privileges to write into the desired directory. To disable permission
739             checking, set ignore_permissions() to a true value:
740              
741             $fs->ignore_permissions(1)
742              
743             Unless explicitly provided, the mode will be set to 0100777 (all
744             permissions set).
745              
746             =cut
747              
748             sub mknod {
749             my $self = shift;
750             my ($path,$mode,$rdev) = @_;
751             my $result = eval {$self->create_inode_and_path($path,'f',$mode,$rdev)};
752             if ($@) {
753             die "file exists" if $@ =~ /not unique|duplicate/i;
754             die $@;
755             }
756             return $result;
757             }
758              
759             =head2 $inode = $fs->mkdir($path,$mode)
760              
761             Create a new directory with the specified path and mode and return the
762             inode of the newly created directory. The path and mode are the same
763             as those described for mknod(), except that the filetype bits for
764             $mode will be set to those for a directory if not provided. Like
765             mknod() this method may raise a fatal error, which should be trapped
766             by an eval{}.
767              
768             Unless explicitly provided, the mode will be set to 0040777 (all
769             permissions set).
770              
771             =cut
772              
773             sub mkdir {
774             my $self = shift;
775             my ($path,$mode) = @_;
776             $self->create_inode_and_path($path,'d',$mode);
777             }
778              
779             =head2 $fs->rename($oldname,$newname)
780              
781             Rename a file or directory. Raises a fatal exception if unsuccessful.
782              
783             =cut
784              
785             sub rename {
786             my $self = shift;
787             my ($oldname,$newname) = @_;
788             my ($inode,$parent,$basename,$dynamic) = $self->path2inode($oldname);
789             die "permission denied" if $dynamic;
790              
791             # if newname exists then this is an error
792             die "file exists" if eval{$self->path2inode($newname)};
793              
794             my $newbase = basename($newname);
795             my $newdir = $self->_dirname($newname);
796             my $newparent = $self->path2inode($newdir); # also does path checking
797             $self->check_perm($parent,W_OK); # can we update the old parent?
798             $self->check_perm($newparent,W_OK); # can we update the new parent?
799              
800             my $dbh = $self->dbh;
801             my $sth = $dbh->prepare_cached(
802             'update path set name=?,parent=? where parent=? and name=?');
803             $sth->execute($newbase,$newparent,$parent,$basename);
804             $sth->finish;
805             1;
806             }
807              
808             =head2 $fs->unlink($path)
809              
810             Unlink the file or symlink located at $path. If this is the last
811             reference to the file (via hard links or filehandles) then the
812             contents of the file and its inode will be permanently removed. This
813             will raise a fatal exception on any errors.
814              
815             =cut
816              
817             sub unlink {
818             my $self = shift;
819             my $path = shift;
820             my ($inode,$parent,$name,$dynamic) = $self->path2inode($path);
821             die "permission denied" if $dynamic;
822              
823             $parent ||= 1;
824             $self->check_perm($parent,W_OK);
825              
826             $name ||= basename($path);
827              
828             $self->_isdir($inode) and croak "$path is a directory";
829             my $dbh = $self->dbh;
830             my $sth = $dbh->prepare_cached("delete from path where inode=? and parent=? and name=?")
831             or die $dbh->errstr;
832             $sth->execute($inode,$parent,$name) or die $dbh->errstr;
833              
834             eval {
835             $dbh->begin_work();
836             $dbh->do("update metadata set links=links-1 where inode=$inode");
837             $dbh->do("update metadata set links=links-1 where inode=$parent");
838             $self->touch($parent,'mtime');
839             $self->touch($parent,'ctime');
840             $dbh->commit();
841             };
842             if ($@) {
843             eval {$dbh->rollback()};
844             die "unlink failed due to $@";
845             }
846             $self->unlink_inode($inode);
847             1;
848             }
849              
850             =head2 $fs->rmdir($path)
851              
852             Remove the directory at $path. This method will fail under a variety
853             of conditions, raising a fatal exception. Common errors include
854             attempting to remove a file rather than a directory or removing a
855             directory that is not empty.
856              
857             =cut
858              
859             sub rmdir {
860             my $self = shift;
861             my $path = shift;
862             my ($inode,$parent,$name) = $self->path2inode($path) ;
863             $self->check_perm($parent,W_OK);
864             $self->_isdir($inode) or croak "$path is not a directory";
865             $self->_getdir($inode ) and croak "$path is not empty";
866              
867             my $dbh = $self->dbh;
868             eval {
869             $dbh->begin_work;
870             my $now = $self->_now_sql;
871             $dbh->do("update metadata set links=links-1,ctime=$now where inode=$inode");
872             $dbh->do("update metadata set links=links-1,ctime=$now where inode=$parent");
873             $dbh->do("delete from path where inode=$inode");
874             $self->touch($parent,'ctime');
875             $self->touch($parent,'mtime');
876             $self->unlink_inode($inode);
877             $dbh->commit;
878             };
879             if($@) {
880             eval {$dbh->rollback()};
881             die "update aborted due to $@";
882             }
883             1;
884             }
885              
886              
887              
888             =head2 $fs->link($oldpath,$newpath)
889              
890             Create a hard link from the file at $oldpath to $newpath. If an error
891             occurs the method will die. Note that this method will allow you to
892             create a hard link to directories as well as files. This is disallowed
893             by the "ln" command, and is generally a bad idea as you can create a
894             filesystem with path loops.
895              
896             =cut
897              
898             sub link {
899             my $self = shift;
900             my ($oldpath,$newpath,$allow_dir_unlink) = @_;
901             $self->check_perm(scalar $self->path2inode($self->_dirname($oldpath)),W_OK);
902             $self->check_perm(scalar $self->path2inode($self->_dirname($newpath)),W_OK);
903             my $inode = $self->path2inode($oldpath);
904             $self->_isdir($inode) && !$allow_dir_unlink
905             and die "hard links of directories not allowed";
906             eval {
907             $self->create_path($inode,$newpath);
908             };
909             if ($@) {
910             die "file exists" if $@ =~ /not unique|duplicate/i;
911             die $@;
912             }
913             1;
914             }
915              
916             =head2 $fs->symlink($oldpath,$newpath)
917              
918             Create a soft (symbolic) link from the file at $oldpath to
919             $newpath. If an error occurs the method will die. It is safe to create
920             symlinks that involve directories.
921              
922             =cut
923              
924             sub symlink {
925             my $self = shift;
926             my ($oldpath,$newpath) = @_;
927             eval {
928             my $newnode = $self->create_inode_and_path($newpath,'l',0120777);
929             $self->write($newpath,$oldpath);
930             };
931             if ($@) {
932             die "file exists" if $@ =~ /not unique|duplicate/i;
933             die $@;
934             }
935             1;
936             }
937              
938             =head2 $path = $fs->readlink($path)
939              
940             Read the symlink at $path and return its target. If an error occurs
941             the method will die.
942              
943             =cut
944              
945             sub readlink {
946             my $self = shift;
947             my $path = shift;
948             my $target = $self->read($path,MAX_PATH_LEN);
949             return $target;
950             }
951              
952             =head2 @entries = $fs->getdir($path)
953              
954             Given a directory in $path, return a list of all entries (files,
955             directories) contained within that directory. The '.' and '..' paths
956             are also always returned. This method checks that the current user has
957             read and execute permissions on the directory, and will raise a
958             permission denied error if not (trap this with an eval{}).
959              
960             Experimental feature: If the directory begins with the magic
961             characters "%%" then getdir will look for a dotfile named ".query"
962             within the directory. ".query" must contain a SQL query that returns a
963             series of one or more inodes. These will be used to populate the
964             directory automagically. The query can span multiple lines, and
965             lines that begin with "#" will be ignored.
966              
967             Here is a simple example which will run on all DBMSs. It displays all
968             files with size greater than 2 Mb:
969              
970             select inode from metadata where size>2000000
971              
972             Another example, which uses MySQL-specific date/time
973             math to find all .jpg files created/modified within the last day:
974              
975             select m.inode from metadata as m,path as p
976             where p.name like '%.jpg'
977             and (now()-interval 1 day) <= m.mtime
978             and m.inode=p.inode
979              
980             (The date/time math syntax is very slightly different for PostgreSQL
981             and considerably different for SQLite)
982              
983             An example that uses extended attributes to search for all documents
984             authored by someone with "Lincoln" in the name:
985              
986             select m.inode from metadata as m,xattr as x
987             where x.name == 'user.Author'
988             and x.value like 'Lincoln%'
989             and m.inode=x.inode
990            
991             The files contained within the magic directories can be read and
992             written just like normal files, but cannot be removed or
993             renamed. Directories are excluded from magic directories. If two or
994             more files from different parts of the filesystem have name clashes,
995             the filesystem will append a number to their end to distinguish them.
996              
997             If the SQL contains an error, then the error message will be contained
998             within a file named "SQL_ERROR".
999              
1000             =cut
1001              
1002             sub getdir {
1003             my $self = shift;
1004             my $path = shift;
1005              
1006             my $inode = $self->path2inode($path);
1007             $self->_isdir($inode) or croak "not directory";
1008             $self->check_perm($inode,X_OK|R_OK);
1009             return $self->_getdir($inode,$path);
1010             }
1011              
1012             sub _getdir {
1013             my $self = shift;
1014             my ($inode,$path) = @_;
1015             my $dbh = $self->dbh;
1016             my $col = $dbh->selectcol_arrayref("select name from path where parent=$inode");
1017             if ($self->allow_magic_dirs && $self->_is_dynamic_dir($inode,$path)) {
1018             my $dynamic = $self->get_dynamic_entries($inode,$path);
1019             push @$col,keys %$dynamic if $dynamic;
1020             }
1021             return '.','..',@$col;
1022             }
1023              
1024             # user has passed a SQL WHERE clause as a directory name
1025             sub _sql_directory {
1026             my $self = shift;
1027             my $path = shift;
1028             (my $where = $path) =~ s/^%(?:where)?//;
1029             my $dbh = $self->dbh;
1030             my $names = eval {$dbh->selectcol_arrayref("select name from metadata,path where metadata.inode=path.inode and $where")};
1031             if ($@) {
1032             my $msg = $@;
1033             $msg =~ s/\s+at.+$//;
1034             $msg =~ s![\n/] !!g;
1035             return ('.','..',$msg);
1036             }
1037             return ('.','..',@$names);
1038             }
1039              
1040             sub get_dynamic_entries {
1041             my $self = shift;
1042             my ($inode,$path) = @_;
1043              
1044             return $self->_get_cached_dynamic_entries($inode,$path)
1045             || $self->_set_cached_dynamic_entries($inode,$path);
1046             }
1047              
1048             sub _get_cached_dynamic_entries {
1049             my $self = shift;
1050             my ($inode,$path) = @_;
1051              
1052             my $dbh = $self->dbh;
1053             my $query = <
1054             select inode,name,parent
1055             from dynamic_cache
1056             where directory=? and time>=?
1057             END
1058             ;
1059             my (%matches,%seenit);
1060             eval {
1061             my $sth = $dbh->prepare_cached($query);
1062             $sth->execute($inode,time()-1); # cache time 1s at most
1063              
1064             while (my ($file_inode,$name,$parent)=$sth->fetchrow_array) {
1065             $name .= '('.($seenit{$name}-1).')' if $seenit{$name}++;
1066             $matches{$name} = [$file_inode,$parent];
1067             }
1068             };
1069             return unless %matches;
1070             return \%matches;
1071             }
1072              
1073             sub _set_cached_dynamic_entries {
1074             my $self = shift;
1075             my ($inode,$path) = @_;
1076              
1077             my $dbh = $self->dbh;
1078              
1079             # create a temporary table to hold the results
1080             $dbh->do(<
1081             create temporary table if not exists dynamic_cache
1082             (directory integer,
1083             time integer,
1084             inode integer,
1085             name varchar(255),
1086             parent integer)
1087             END
1088             ;
1089              
1090             $dbh->do("delete from dynamic_cache where directory=$inode");
1091              
1092             # look for a file named .query
1093             my ($query_inode) =
1094             $dbh->selectrow_array("select inode from path where name='.query' and parent=$inode");
1095             return unless $query_inode;
1096              
1097             # fetch the query
1098             my $sql = $self->read(undef,4096,0,$query_inode) or return;
1099             $sql =~ s/#.+\n//g;
1100              
1101             # run the query
1102             my $isdir = 0x4000;
1103             my $query = <
1104             insert into dynamic_cache (directory,time,inode,name,parent)
1105             select ?,?,p.inode,p.name,p.parent
1106             from path as p,metadata as m
1107             where p.inode=m.inode
1108             and ($isdir&m.mode)=0
1109             and p.inode in ($sql)
1110             END
1111             ;;
1112             my $sth;
1113             eval {
1114             $sth = $dbh->prepare($query);
1115             $sth->execute($inode,time());
1116             };
1117              
1118             my $error_file = "$path/SQL_ERROR";
1119             if ($@) {
1120             my $msg = $@;
1121             eval {
1122             my ($i) = eval {$self->_path2inode($error_file)};
1123             $i ||= $self->mknod($error_file,0444,0);
1124             $self->ftruncate($error_file,0,$i);
1125             $self->write($error_file,$msg,0,$i);
1126             };
1127             warn $@ if $@;
1128             return;
1129             } else {
1130             eval{
1131             $self->unlink($error_file) if $self->_path2inode($error_file);
1132             };
1133             }
1134             $sth->finish;
1135             return $self->_get_cached_dynamic_entries($inode,$path);
1136             }
1137              
1138             =head2 $boolean = $fs->isdir($path)
1139              
1140             Convenience method. Returns true if the path corresponds to a
1141             directory. May raise a fatal error if the provided path is invalid.
1142              
1143             =cut
1144              
1145             sub isdir {
1146             my $self = shift;
1147             my $path = shift;
1148             my $inode = $self->path2inode($path) ;
1149             return $self->_isdir($inode);
1150             }
1151              
1152             sub _isdir {
1153             my $self = shift;
1154             my $inode = shift;
1155             my $dbh = $self->dbh;
1156             my $mask = 0xf000;
1157             my $isdir = 0x4000;
1158             my ($result) = $dbh->selectrow_array("select ($mask&mode)=$isdir from metadata where inode=$inode")
1159             or die $dbh->errstr;
1160             return $result;
1161             }
1162              
1163             sub _is_dynamic_dir {
1164             my $self = shift;
1165             my ($inode,$path) = @_;
1166             return unless $path;
1167             return $path =~ m!(?:^|/)%%[^/]+$! && $self->_isdir($inode)
1168             }
1169              
1170             =head2 $fs->chown($path,$uid,$gid)
1171              
1172             This method changes the user and group ids for the indicated path. It
1173             raises a fatal exception on errors.
1174              
1175             =cut
1176              
1177             sub chown {
1178             my $self = shift;
1179             my ($path,$uid,$gid) = @_;
1180             my $inode = $self->path2inode($path) ;
1181              
1182             # permission checking here
1183             unless ($self->ignore_permissions) {
1184             my $ctx = $self->get_context;
1185             die "permission denied" unless $uid == 0xffffffff || $ctx->{uid} == 0 || $ctx->{uid}==$uid;
1186              
1187             my $groups = $self->get_groups(@{$ctx}{'uid','gid'});
1188             die "permission denied" unless $gid == 0xffffffff || $ctx->{uid} == 0 || $ctx->{gid}==$gid || $groups->{$gid};
1189             }
1190              
1191             my $dbh = $self->dbh;
1192             eval {
1193             $dbh->begin_work();
1194             $dbh->do("update metadata set uid=$uid where inode=$inode") if $uid!=0xffffffff;
1195             $dbh->do("update metadata set gid=$gid where inode=$inode") if $gid!=0xffffffff;
1196             $self->touch($inode,'ctime');
1197             $dbh->commit();
1198             };
1199             if ($@) {
1200             eval {$dbh->rollback()};
1201             die "update aborted due to $@";
1202             }
1203             1;
1204             }
1205              
1206             =head2 $fs->chmod($path,$mode)
1207              
1208             This method changes the access mode for the file or directory at the
1209             indicated path. The mode in this case is just the three octal word
1210             access mode, not the combination of access mode and path type used in
1211             mknod().
1212              
1213             =cut
1214              
1215             sub chmod {
1216             my $self = shift;
1217             my ($path,$mode) = @_;
1218             my $inode = $self->path2inode($path) ;
1219             $self->check_perm($inode,F_OK);
1220             my $dbh = $self->dbh;
1221             my $f000 = 0xf000;
1222             my $now = $self->_now_sql;
1223             return $dbh->do("update metadata set mode=(($f000&mode)|$mode),ctime=$now where inode=$inode");
1224             }
1225              
1226             =head2 @stat = $fs->fgetattr($path,$inode)
1227              
1228             Return the 13-element file attribute list returned by Perl's stat()
1229             function, describing an existing file or directory. You may pass the
1230             path, and/or the inode of the file/directory. If both are passed, then
1231             the inode takes precedence.
1232              
1233             The returned list will contain:
1234              
1235             0 dev device number of filesystem
1236             1 ino inode number
1237             2 mode file mode (type and permissions)
1238             3 nlink number of (hard) links to the file
1239             4 uid numeric user ID of file's owner
1240             5 gid numeric group ID of file's owner
1241             6 rdev the device identifier (special files only)
1242             7 size total size of file, in bytes
1243             8 atime last access time in seconds since the epoch
1244             9 mtime last modify time in seconds since the epoch
1245             10 ctime inode change time in seconds since the epoch (*)
1246             11 blksize preferred block size for file system I/O
1247             12 blocks actual number of blocks allocated
1248              
1249             =cut
1250              
1251             sub fgetattr {
1252             my $self = shift;
1253             my ($path,$inode) = @_;
1254             $inode ||= $self->path2inode($path);
1255             my $dbh = $self->dbh;
1256             my ($ino,$mode,$uid,$gid,$rdev,$nlinks,$ctime,$mtime,$atime,$size) =
1257             $dbh->selectrow_array($self->_fgetattr_sql($inode));
1258             $ino or die 'not found';
1259              
1260             # make sure write buffer contributes
1261             if (my $blocks = $Blockbuff{$inode}) {
1262             lock $blocks;
1263             if (keys %$blocks) {
1264             my ($biggest) = sort {$b<=>$a} keys %$blocks;
1265             my $offset = $self->blocksize * $biggest + length $blocks->{$biggest};
1266             $size = $offset if $offset > $size;
1267             }
1268             }
1269              
1270             my $dev = 0;
1271             my $blocks = 1;
1272             my $blksize = $self->blocksize;
1273             return ($dev,$ino,$mode,$nlinks,$uid,$gid,$rdev,$size,$atime,$mtime,$ctime,$blksize,$blocks);
1274             }
1275              
1276             =head2 @stat = $fs->getattr($path)
1277              
1278             Similar to fgetattr() but only the path is accepted.
1279              
1280             =cut
1281              
1282             sub getattr {
1283             my $self = shift;
1284             my $path = shift;
1285             my $inode = $self->path2inode($path);
1286             return $self->fgetattr($path,$inode);
1287             }
1288              
1289             =head2 $inode = $fs->open($path,$flags,$info)
1290              
1291             Open the file at $path and return its inode. $flags are a bitwise
1292             OR-ing of the access mode constants including O_RDONLY, O_WRONLY,
1293             O_RDWR, O_CREAT, and $info is a hash reference containing flags from
1294             the Fuse module. The latter is currently ignored.
1295              
1296             This method checks read/write permissions on the file and containing
1297             directories, unless ignore_permissions is set to true. The open method
1298             also increments the file's inuse counter, ensuring that even if it is
1299             unlinked, its contents will not be removed until the last open
1300             filehandle is closed.
1301              
1302             The flag constants can be obtained from POSIX.
1303              
1304             =cut
1305              
1306             sub open {
1307             my $self = shift;
1308             my ($path,$flags,$info) = @_;
1309             my $inode = $self->path2inode($path);
1310             $self->check_open_perm($inode,$flags);
1311             $self->dbh->do("update metadata set inuse=inuse+1 where inode=$inode");
1312             return $inode;
1313             }
1314              
1315             =head2 $fh->release($inode)
1316              
1317             Release a file previously opened with open(), decrementing its inuse
1318             count. Be careful to balance calls to open() with release(), or the
1319             file will have an inconsistent use count.
1320              
1321             =cut
1322              
1323             sub release {
1324             my ($self,$inode) = @_;
1325             $self->flush(undef,$inode); # write cached blocks
1326             my $dbh = $self->dbh;
1327             $dbh->do("update metadata set inuse=inuse-1 where inode=$inode");
1328             $self->unlink_inode($inode);
1329             return 0;
1330             }
1331              
1332              
1333             =head2 $data = $fs->read($path,$length,$offset,$inode)
1334              
1335             Read $length bytes of data from the file at $path, starting at
1336             position $offset. You may optionally pass an inode to the method to
1337             read from a previously-opened file.
1338              
1339             On success, the requested data will be returned. Otherwise a fatal
1340             exception will be raised (which can be trapped with an eval{}).
1341              
1342             Note that you do not need to open the file before reading from
1343             it. Permission checking is not performed in this call, but in the
1344             (optional) open() call.
1345              
1346             =cut
1347              
1348             sub read {
1349             my $self = shift;
1350             my ($path,$length,$offset,$inode) = @_;
1351              
1352             $inode || defined $path or croak "no path or inode provided";
1353              
1354             unless ($inode) {
1355             $inode = $self->path2inode($path);
1356             $self->_isdir($inode) and croak "$path is a directory";
1357             }
1358             $offset ||= 0;
1359              
1360             my $blksize = $self->blocksize;
1361             my $first_block = int($offset / $blksize);
1362             my $last_block = int(($offset+$length) / $blksize);
1363             my $start = $offset % $blksize;
1364            
1365             $self->flush(undef,$inode);
1366             my $get_atime = $self->_get_unix_timestamp_sql('atime');
1367             my $get_mtime = $self->_get_unix_timestamp_sql('mtime');
1368             my ($current_length,$atime,$mtime) =
1369             $self->dbh->selectrow_array("select size,$get_atime,$get_mtime from metadata where inode=$inode");
1370             if ($length+$offset > $current_length) {
1371             $length = $current_length - $offset;
1372             }
1373             my $data = $self->_read_direct($inode,$start,$length,$first_block,$last_block);
1374             $self->touch($inode,'atime') if length $data && $atime < $mtime;
1375             return $data;
1376             }
1377              
1378             =head2 $bytes = $fs->write($path,$data,$offset,$inode)
1379              
1380             Write the data provided in $data into the file at $path, starting at
1381             position $offset. You may optionally pass an inode to the method to
1382             read from a previously-opened file.
1383              
1384             On success, the number of bytes written will be returned. Otherwise a fatal
1385             exception will be raised (which can be trapped with an eval{}).
1386              
1387             Note that the file does not previously need to have been opened in
1388             order to write to it, and permission checking is not performed at this
1389             level. This checking is performed in the (optional) open() call.
1390              
1391             =cut
1392              
1393             sub write {
1394             my $self = shift;
1395             my ($path,$data,$offset,$inode) = @_;
1396             $inode || defined $path or croak "no path or inode provided";
1397              
1398             unless ($inode) {
1399             $inode = $self->path2inode($path);
1400             $self->_isdir($inode) and croak "$path is a directory";
1401             }
1402             $offset ||= 0;
1403              
1404             my $blksize = $self->blocksize;
1405             my $first_block = int($offset / $blksize);
1406             my $start = $offset % $blksize;
1407              
1408             my $block = $first_block;
1409             my $bytes_to_write = length $data;
1410             my $bytes_written = 0;
1411             unless ($Blockbuff{$inode}) {
1412             my %hash;
1413             $Blockbuff{$inode}=share(%hash);
1414             }
1415             my $blocks = $Blockbuff{$inode}; # blockno=>data
1416             lock $blocks;
1417              
1418             my $dbh = $self->dbh;
1419             while ($bytes_to_write > 0) {
1420             my $bytes = $blksize > ($bytes_to_write+$start) ? $bytes_to_write : ($blksize-$start);
1421             my $current_length = length($blocks->{$block}||'');
1422              
1423             if ($bytes < $blksize && !$current_length) { # partial block replacement, and not currently cached
1424             my $sth = $dbh->prepare_cached('select contents,length(contents) from extents where inode=? and block=?');
1425             $sth->execute($inode,$block);
1426             ($blocks->{$block},$current_length) = $sth->fetchrow_array();
1427             $current_length ||= 0;
1428             $sth->finish;
1429             }
1430              
1431             if ($start > $current_length) { # hole in current block
1432             my $padding = "\0" x ($start-$current_length);
1433             $padding ||= '';
1434             $blocks->{$block} .= $padding;
1435             }
1436              
1437             if ($blocks->{$block}) {
1438             substr($blocks->{$block},$start,$bytes,substr($data,$bytes_written,$bytes));
1439             } else {
1440             $blocks->{$block} = substr($data,$bytes_written,$bytes);
1441             }
1442              
1443             $start = 0; # no more offsets
1444             $block++;
1445             $bytes_written += $bytes;
1446             $bytes_to_write -= $bytes;
1447             }
1448             $self->flush(undef,$inode) if keys %$blocks > $self->flushblocks;
1449             return $bytes_written;
1450             }
1451              
1452             sub _write_blocks {
1453             my $self = shift;
1454             my ($inode,$blocks,$blksize) = @_;
1455              
1456             my $dbh = $self->dbh;
1457             my ($length) = $dbh->selectrow_array("select size from metadata where inode=$inode");
1458             my $hwm = $length; # high water mark ;-)
1459              
1460             eval {
1461             $dbh->begin_work;
1462             my $sth = $dbh->prepare_cached(<errstr;
1463             replace into extents (inode,block,contents) values (?,?,?)
1464             END
1465             ;
1466             for my $block (keys %$blocks) {
1467             my $data = $blocks->{$block};
1468             $sth->execute($inode,$block,$data);
1469             my $a = $block * $blksize + length($data);
1470             $hwm = $a if $a > $hwm;
1471             }
1472             $sth->finish;
1473             my $now = $self->_now_sql;
1474             $dbh->do("update metadata set size=$hwm,mtime=$now where inode=$inode");
1475             $dbh->commit();
1476             };
1477              
1478             if ($@) {
1479             my $msg = $@;
1480             eval{$dbh->rollback()};
1481             warn $msg;
1482             die "write failed with $msg";
1483             return;
1484             }
1485              
1486             1;
1487             }
1488              
1489             =head2 $fs->flush( [$path,[$inode]] )
1490              
1491             Before data is written to the database, it is cached for a while in
1492             memory. flush() will force data to be written to the database. You may
1493             pass no arguments, in which case all cached data will be written, or
1494             you may provide the path and/or inode to an existing file to flush
1495             just the unwritten data associated with that file.
1496              
1497             =cut
1498              
1499             sub flush {
1500             my $self = shift;
1501             my ($path,$inode) = @_;
1502              
1503             $inode ||= $self->path2inode($path) if $path;
1504              
1505             # if called with no inode, then recursively call ourselves
1506             # to flush all cached inodes
1507             unless ($inode) {
1508             for my $i (keys %Blockbuff) {
1509             $self->flush(undef,$i);
1510             }
1511             return;
1512             }
1513              
1514             my $blocks = $Blockbuff{$inode} or return;
1515             my $blksize = $self->blocksize;
1516              
1517             lock $blocks;
1518             my $result = $self->_write_blocks($inode,$blocks,$blksize) or die "flush failed";
1519              
1520             delete $Blockbuff{$inode};
1521             }
1522              
1523             # This type of read is invoked when there is no write buffer for
1524             # the file. It executes a single SQL query across the data table.
1525             sub _read_direct {
1526             my $self = shift;
1527             my ($inode,$start,$length,$first_block,$last_block) = @_;
1528              
1529             my $dbh = $self->dbh;
1530             my $sth = $dbh->prepare_cached(<
1531             select block,contents
1532             from extents where inode=?
1533             and block between ? and ?
1534             order by block
1535             END
1536             ;
1537             $sth->execute($inode,$first_block,$last_block);
1538              
1539             my $blksize = $self->blocksize;
1540             my $previous_block;
1541             my $data = '';
1542             while (my ($block,$contents) = $sth->fetchrow_array) {
1543             $previous_block = $block unless defined $previous_block;
1544             # a hole spanning an entire block
1545             if ($block - $previous_block > 1) {
1546             $data .= "\0"x($blksize*($block-$previous_block-1));
1547             }
1548             $previous_block = $block;
1549            
1550             # a hole spanning a portion of a block
1551             if (length $contents < $blksize && $block < $last_block) {
1552             $contents .= "\0"x($blksize-length($contents)); # this is a hole!
1553             }
1554             $data .= substr($contents,$start,$length);
1555             $length -= $blksize;
1556             $start = 0;
1557             }
1558             $sth->finish();
1559             return $data;
1560             }
1561              
1562             =head2 $fs->truncate($path,$length)
1563              
1564             Shorten the contents of the file located at $path to the length
1565             indicated by $length.
1566              
1567             =cut
1568              
1569             sub truncate {
1570             my $self = shift;
1571             my ($path,$length) = @_;
1572             $self->ftruncate($path,$length);
1573             }
1574              
1575             =head2 $fs->ftruncate($path,$length,$inode)
1576              
1577             Like truncate() but you may provide the inode instead of the path.
1578             This is called by Fuse to truncate an open file.
1579              
1580             =cut
1581              
1582             sub ftruncate {
1583             my $self = shift;
1584             my ($path,$length,$inode) = @_;
1585              
1586             $inode ||= $self->path2inode($path);
1587             $self->_isdir($inode) and croak "$path is a directory";
1588              
1589             my $dbh = $self->dbh;
1590             $length ||= 0;
1591              
1592             # check that length isn't greater than current position
1593             my @stat = $self->getattr($path);
1594             $stat[7] >= $length or croak "length beyond end of file";
1595              
1596             my $last_block = int($length/$self->blocksize);
1597             my $trunc = $length % $self->blocksize;
1598             eval {
1599             $dbh->begin_work;
1600             $dbh->do("delete from extents where inode=$inode and block>$last_block");
1601             $dbh->do("update extents set contents=substr(contents,1,$trunc) where inode=$inode and block=$last_block");
1602             $dbh->do("update metadata set size=$length where inode=$inode");
1603             $self->touch($inode,'mtime');
1604             $dbh->commit;
1605             };
1606             if ($@) {
1607             eval {$dbh->rollback()};
1608             die "Couldn't update because $@";
1609             }
1610             1;
1611             }
1612              
1613             =head2 $fs->utime($path,$atime,$mtime)
1614              
1615             Update the atime and mtime of the indicated file or directory to the
1616             values provided. You must have write permissions to the file in order
1617             to do this.
1618              
1619             =cut
1620              
1621             sub utime {
1622             my $self = shift;
1623             my ($path,$atime,$mtime) = @_;
1624             my $inode = $self->path2inode($path) ;
1625             $self->check_perm($inode,W_OK);
1626             my $dbh = $self->dbh;
1627             my $sth = $dbh->prepare_cached($self->_update_utime_sql);
1628             my $result = $sth->execute($atime,$mtime,$inode);
1629             $sth->finish();
1630             return $result;
1631             }
1632              
1633             =head2 $fs->access($path,$access_mode)
1634              
1635             This method checks the current user's permissions for a file or
1636             directory. The arguments are the path to the item of interest, and the
1637             mode is one of the following constants:
1638              
1639             F_OK check for existence of file
1640              
1641             or a bitwise OR of one or more of:
1642              
1643             R_OK check that the file can be read
1644             W_OK check that the file can be written to
1645             X_OK check that the file is executable
1646              
1647             These constants can be obtained from the POSIX module.
1648              
1649             =cut
1650              
1651             sub access {
1652             my $self = shift;
1653             my ($path,$access_mode) = @_;
1654             my $inode = $self->path2inode($path);
1655             return $self->check_perm($inode,$access_mode);
1656             }
1657              
1658             sub check_open_perm {
1659             my $self = shift;
1660             my ($inode,$flags) = @_;
1661             $flags &= 0x3;
1662             my $wants_read = $flags==O_RDONLY || $flags==O_RDWR;
1663             my $wants_write = $flags==O_WRONLY || $flags==O_RDWR;
1664             my $mask = 0000;
1665             $mask |= R_OK if $wants_read;
1666             $mask |= W_OK if $wants_write;
1667             return $self->check_perm($inode,$mask);
1668             }
1669              
1670             =head2 $errno = $fs->errno($message)
1671              
1672             Most methods defined by this module are called within an eval{} to
1673             trap errors. On an error, the message contained in $@ is passed to
1674             errno() to turn it into a UNIX error code. The error code is then
1675             returned to the Fuse module.
1676              
1677             The following is the limited set of mappings performed:
1678              
1679             Eval{} error message Unix Errno Context
1680             -------------------- ---------- -------
1681              
1682             not found ENOENT Path lookups
1683             file exists EEXIST Path creation
1684             is a directory EISDIR Attempt to open/read/write a directory
1685             not a directory ENOTDIR Attempt to list entries from a file
1686             length beyond end of file EINVAL Truncate file to longer than current length
1687             not empty ENOTEMPTY Attempt to remove a directory that is in use
1688             permission denied EACCESS Access modes don't allow requested operation
1689              
1690             The full error message usually has further detailed information. For
1691             example the full error message for "not found" is "$path not found"
1692             where $path contains the requested path.
1693              
1694             All other errors, including problems in the underlying DBI database
1695             layer, result in an error code of EIO ("I/O error"). These constants
1696             can be obtained from POSIX.
1697              
1698             =cut
1699              
1700              
1701             sub errno {
1702             my $self = shift;
1703             my $message = shift;
1704             return -ENOENT() if $message =~ /not found/;
1705             return -EEXIST() if $message =~ /file exists/;
1706             return -EISDIR() if $message =~ /is a directory/;
1707             return -EPERM() if $message =~ /hard links of directories not allowed/;
1708             return -ENOTDIR() if $message =~ /not a directory/;
1709             return -EINVAL() if $message =~ /length beyond end of file/;
1710             return -ENOTEMPTY() if $message =~ /not empty/;
1711             return -EACCES() if $message =~ /permission denied/;
1712             return -ENOATTR() if $message =~ /no such attribute/;
1713             return -EEXIST() if $message =~ /attribute exists/;
1714             warn $message; # something unexpected happened!
1715             return -EIO();
1716             }
1717              
1718             =head2 $result = $fs->setxattr($path,$name,$val,$flags)
1719              
1720             This method sets the extended attribute named $name to the value
1721             indicated by $val for the file or directory in $path. The Fuse
1722             documentation states that $flags will be one of XATTR_REPLACE or
1723             XATTR_CREATE, but in my testing I have only seen the value 0 passed.
1724              
1725             On success, the method returns 0.
1726              
1727             =cut
1728              
1729             sub setxattr {
1730             my $self = shift;
1731             my ($path,$xname,$xval,$xflags) = @_;
1732             my $inode = $self->path2inode($path);
1733             my $dbh = $self->dbh;
1734             if (!$xflags) {
1735             my $sql = 'replace into xattr (inode,name,value) values (?,?,?)';
1736             my $sth = $dbh->prepare_cached($sql);
1737             $sth->execute($inode,$xname,$xval);
1738             $sth->finish;
1739             }
1740             elsif ($xflags&XATTR_REPLACE) {
1741             my $sql = 'update xattr set value=? where inode=? and name=?';
1742             my $sth = $dbh->prepare_cached($sql);
1743             my $rows = eval {$sth->execute($xval,$inode,$xname)};
1744             $sth->finish;
1745             die "no such attribute" unless $rows>0;
1746             }
1747             elsif ($xflags&XATTR_CREATE) {
1748             my $sql = 'insert into xattr (inode,name,value) values (?,?,?)';
1749             my $sth = $dbh->prepare_cached($sql);
1750             eval {$sth->execute($inode,$xname,$xval)};
1751             die "attribute exists" if $@ =~ /not unique|duplicate/i;
1752             $sth->finish;
1753             } else {
1754             die "Can't interpret value of setxattr flags=$xflags";
1755             }
1756             return 0;
1757             }
1758              
1759             =head2 $val = $fs->getxattr($path,$name)
1760              
1761             Reads the extended attribute named $name from the file or directory at
1762             $path and returns the value. Will return undef if the attribute not
1763             found.
1764              
1765             Note that when the filesystem is mounted, the Fuse interface provides
1766             no way to distinguish between an attribute that does not exist versus
1767             one that does exist but has value "0". The only workaround for this is
1768             to use "attr -l" to list the attributes and look for the existence of
1769             the desired attribute.
1770              
1771              
1772             =cut
1773              
1774             sub getxattr {
1775             my $self = shift;
1776             my ($path,$xname) = @_;
1777             my $inode = $self->path2inode($path);
1778             my $dbh = $self->dbh;
1779             my $name = $dbh->quote($xname);
1780             my ($value) = $dbh->selectrow_array("select value from xattr where inode=$inode and name=$name");
1781             return $value;
1782             }
1783              
1784             =head2 @attribute_names = $fs->listxattr($path)
1785              
1786             List all xattributes for the file or directory at the indicated path
1787             and return them as a list.
1788              
1789             =cut
1790              
1791             sub listxattr {
1792             my $self = shift;
1793             my $path = shift;
1794             my $inode = $self->path2inode($path);
1795             my $names = $self->dbh->selectcol_arrayref("select name from xattr where inode=$inode");
1796             $names ||= [];
1797             return @$names;
1798             }
1799              
1800             =head2 $fs->removexattr($path,$name)
1801              
1802             Remove the attribute named $name for path $path. Will raise a "no such
1803             attribute" error if then if the attribute does not exist.
1804              
1805             =cut
1806              
1807             sub removexattr {
1808             my $self = shift;
1809             my ($path,$xname) = @_;
1810             my $dbh = $self->dbh;
1811             my $inode = $self->path2inode($path);
1812             my $sth = $dbh->prepare_cached("delete from xattr where inode=? and name=?");
1813             $sth->execute($inode,$xname);
1814             $sth->rows > 0 or die "no such attribute named $xname";
1815             $sth->finish;
1816             return 0;
1817             }
1818              
1819             =head1 LOW LEVEL METHODS
1820              
1821             The following methods may be of interest for those who wish to
1822             understand how this module works, or want to subclass and extend this
1823             module.
1824              
1825             =cut
1826              
1827             =head2 $fs->initialize_schema
1828              
1829             This method is called to initialize the database schema. The database
1830             must already exist and be writable by the current user. All previous
1831             data will be deleted from the database.
1832              
1833             The default schema contains three tables:
1834              
1835             metadata -- Information about the inode used for the stat() call. This
1836             includes its length, modification and access times,
1837             permissions, and ownership. There is one row per inode,
1838             and the inode is the table's primary key.
1839              
1840             path -- Maps paths to inodes. Each row is a distinct component
1841             of a path and contains the name of the component, the
1842             inode of the parent component, and the inode corresponding
1843             to the component. This is illustrated below.
1844              
1845             extents -- Maps inodes to the contents of the file. Each row consists
1846             of the inode of the file, the block number of the data, and
1847             a blob containing the data in that block.
1848              
1849             For the mysql adapter, here is the current schema:
1850              
1851             metadata:
1852              
1853             +--------+------------+------+-----+---------------------+----------------+
1854             | Field | Type | Null | Key | Default | Extra |
1855             +--------+------------+------+-----+---------------------+----------------+
1856             | inode | int(10) | NO | PRI | NULL | auto_increment |
1857             | mode | int(10) | NO | | NULL | |
1858             | uid | int(10) | NO | | NULL | |
1859             | gid | int(10) | NO | | NULL | |
1860             | rdev | int(10) | YES | | 0 | |
1861             | links | int(10) | YES | | 0 | |
1862             | inuse | int(10) | YES | | 0 | |
1863             | size | bigint(20) | YES | | 0 | |
1864             | mtime | timestamp | NO | | 0000-00-00 00:00:00 | |
1865             | ctime | timestamp | NO | | 0000-00-00 00:00:00 | |
1866             | atime | timestamp | NO | | 0000-00-00 00:00:00 | |
1867             +--------+------------+------+-----+---------------------+----------------+
1868              
1869             path:
1870              
1871             +--------+--------------+------+-----+---------+-------+
1872             | Field | Type | Null | Key | Default | Extra |
1873             +--------+--------------+------+-----+---------+-------+
1874             | inode | int(10) | NO | | NULL | |
1875             | name | varchar(255) | NO | | NULL | |
1876             | parent | int(10) | YES | MUL | NULL | |
1877             +--------+--------------+------+-----+---------+-------+
1878              
1879             extents:
1880              
1881             +----------+---------+------+-----+---------+-------+
1882             | Field | Type | Null | Key | Default | Extra |
1883             +----------+---------+------+-----+---------+-------+
1884             | inode | int(10) | YES | MUL | NULL | |
1885             | block | int(10) | YES | | NULL | |
1886             | contents | blob | YES | | NULL | |
1887             +----------+---------+------+-----+---------+-------+
1888              
1889             The B is straightforward. The meaning of most columns
1890             can be inferred from the stat(2) manual page. The only columns that
1891             may be mysterious are "links" and "inuse". "links" describes the
1892             number of distinct paths involving a file or directory. Files start
1893             out with one link and are incremented by one every time a hardlink is
1894             created (symlinks don't count). Directories start out with two links
1895             (one for '..' and the other for '.') and are incremented by one every
1896             time a file or subdirectory is added to the directory. The "inuse"
1897             column is incremented every time a file is opened for reading or
1898             writing, and decremented when the file is closed. It is used to
1899             prevent the content from being deleted if the file is still in use.
1900              
1901             The B is organized to allow rapid translation from a pathname
1902             to an inode. Each entry in the tree is identified by its inode, its
1903             name, and the inode of its parent directory. The inode of the root "/"
1904             node is hard-coded to 1. The following steps show the effect of
1905             creating subdirectories and files on the path table:
1906              
1907             After initial filesystem initialization there is only one entry
1908             in paths corresponding to the root directory. The root has no parent:
1909              
1910             +-------+------+--------+
1911             | inode | name | parent |
1912             +-------+------+--------+
1913             | 1 | / | NULL |
1914             +-------+------+--------+
1915              
1916             $ mkdir directory1
1917             +-------+------------+--------+
1918             | inode | name | parent |
1919             +-------+------------+--------+
1920             | 1 | / | NULL |
1921             | 2 | directory1 | 1 |
1922             +-------+------------+--------+
1923              
1924             $ mkdir directory1/subdir_1_1
1925              
1926             +-------+------------+--------+
1927             | inode | name | parent |
1928             +-------+------------+--------+
1929             | 1 | / | NULL |
1930             | 2 | directory1 | 1 |
1931             | 3 | subdir_1_1 | 2 |
1932             +-------+------------+--------+
1933              
1934             $ mkdir directory2
1935              
1936             +-------+------------+--------+
1937             | inode | name | parent |
1938             +-------+------------+--------+
1939             | 1 | / | NULL |
1940             | 2 | directory1 | 1 |
1941             | 3 | subdir_1_1 | 2 |
1942             | 4 | directory2 | 1 |
1943             +-------+------------+--------+
1944              
1945             $ touch directory2/file1.txt
1946              
1947             +-------+------------+--------+
1948             | inode | name | parent |
1949             +-------+------------+--------+
1950             | 1 | / | NULL |
1951             | 2 | directory1 | 1 |
1952             | 3 | subdir_1_1 | 2 |
1953             | 4 | directory2 | 1 |
1954             | 5 | file1.txt | 4 |
1955             +-------+------------+--------+
1956              
1957             $ ln directory2/file1.txt link_to_file1.txt
1958              
1959             +-------+-------------------+--------+
1960             | inode | name | parent |
1961             +-------+-------------------+--------+
1962             | 1 | / | NULL |
1963             | 2 | directory1 | 1 |
1964             | 3 | subdir_1_1 | 2 |
1965             | 4 | directory2 | 1 |
1966             | 5 | file1.txt | 4 |
1967             | 5 | link_to_file1.txt | 1 |
1968             +-------+-------------------+--------+
1969              
1970             Notice in the last step how creating a hard link establishes a second
1971             entry with the same inode as the original file, but with a different
1972             name and parent.
1973              
1974             The inode for path /directory2/file1.txt can be found with this
1975             recursive-in-spirit SQL fragment:
1976              
1977             select inode from path where name="file1.txt"
1978             and parent in
1979             (select inode from path where name="directory2"
1980             and parent in
1981             (select 1)
1982             )
1983              
1984             The B provides storage of file (and symlink)
1985             contents. During testing, it turned out that storing the entire
1986             contents of a file into a single BLOB column provided very poor random
1987             access performance. So instead the contents are now broken into blocks
1988             of constant size 4096 bytes. Each row of the table corresponds to the
1989             inode of the file, the block number (starting at 0), and the data
1990             contained within the block. In addition to dramatically better
1991             read/write performance, this scheme allows sparse files (files
1992             containing "holes") to be stored efficiently: Blocks that fall within
1993             holes are completely absent from the table, while those that lead into
1994             a hole are shorter than the full block length.
1995              
1996             The logical length of the file is stored in the metadata size
1997             column.
1998              
1999             If you have subclassed DBI::Filesystem and wish to adjust the default
2000             schema (such as adding indexes), this is the place to do it. Simply
2001             call the inherited initialize_schema(), and then alter the tables as
2002             you please.
2003              
2004             =cut
2005              
2006             sub initialize_schema {
2007             my $self = shift;
2008             my $dbh = $self->dbh;
2009             $dbh->do('drop table if exists metadata') or croak $dbh->errstr;
2010             $dbh->do('drop table if exists path') or croak $dbh->errstr;
2011             $dbh->do('drop table if exists extents') or croak $dbh->errstr;
2012             $dbh->do('drop table if exists sqlfs_vars') or croak $dbh->errstr;
2013             $dbh->do('drop table if exists xattr') or croak $dbh->errstr;
2014             eval{$dbh->do('drop index if exists iblock')};
2015             eval{$dbh->do('drop index if exists ipath')};
2016              
2017            
2018             $dbh->do($_) foreach split ';',$self->_metadata_table_def;
2019             $dbh->do($_) foreach split ';',$self->_path_table_def;
2020             $dbh->do($_) foreach split ';',$self->_extents_table_def;
2021             $dbh->do($_) foreach split ';',$self->_variables_table_def;
2022             $dbh->do($_) foreach split ';',$self->_xattr_table_def;
2023              
2024             # create the root node
2025             # should update this to use fuse_get_context to get proper uid, gid and masked permissions
2026             my $ctx = $self->get_context;
2027             my $mode = (0040000|0777)&~$ctx->{umask};
2028             my $uid = $ctx->{uid};
2029             my $gid = $ctx->{gid};
2030             my $timestamp = $self->_now_sql();
2031             # bug: we assume that sequence begins with 1
2032             $dbh->do("insert into metadata (mode,uid,gid,links,mtime,ctime,atime) values ($mode,$uid,$gid,2,$timestamp,$timestamp,$timestamp)")
2033             or croak $dbh->errstr;
2034             $dbh->do("insert into path (inode,name,parent) values (1,'/',null)")
2035             or croak $dbh->errstr;
2036             $self->set_schema_version($self->schema_version);
2037             }
2038              
2039             =head2 $ok = $fs->check_schema
2040              
2041             This method is called when opening a preexisting database. It checks
2042             that the metadata, path and extents tables exist in the database and
2043             have the expected relationships. Returns true if the check passes.
2044              
2045             =cut
2046              
2047             sub check_schema {
2048             my $self = shift;
2049             local $self->{dbh}; # to avoid cloning database handle into child threads
2050             my ($result) = eval {
2051             $self->dbh->selectrow_array('select 1 from metadata as m,path as p left join extents as e on e.inode=p.inode where m.inode=1 and p.parent=1');
2052             };
2053             return !$@;
2054             }
2055              
2056             =head2 $version = $fs->schema_version
2057              
2058             This method returns the schema version understood by this module. It
2059             is used when opening up a sqlfs databse to check whether database was
2060             created by an earlier or later version of the software. The schema
2061             version is distinct from the library version since updates to the library
2062             do not always necessitate updates to the schema.
2063              
2064             Versions are small integers beginning at 1.
2065              
2066             =cut
2067              
2068             sub schema_version {
2069             return SCHEMA_VERSION;
2070             }
2071              
2072             =head2 $version = $fs->get_schema_version
2073              
2074             This returns the schema version known to a preexisting database.
2075              
2076             =cut
2077              
2078             sub get_schema_version {
2079             my $self = shift;
2080             my ($result) = eval { $self->dbh->selectrow_array("select value from sqlfs_vars where name='schema_version'") };
2081             return $result || 1;
2082             }
2083              
2084             =head2 $fs->set_schema_version($version)
2085              
2086             This sets the databases's schema version to the indicated value.
2087              
2088             =cut
2089              
2090             sub set_schema_version {
2091             my $self = shift;
2092             my $version = shift;
2093             $self->dbh->do("replace into sqlfs_vars (name,value) values ('schema_version','$version')");
2094             }
2095              
2096             =head2 $fs->check_schema_version
2097              
2098             This checks whether the schema version in a preexisting database is
2099             compatible with the version known to the library. If the version is
2100             from an earlier version of the library, then schema updating will be
2101             attempted. If the database was created by a newer version of the
2102             software, the method will raise a fatal exception.
2103              
2104             =cut
2105              
2106             sub check_schema_version {
2107             my $self = shift;
2108             my $current_version = $self->schema_version;
2109             my $db_version = $self->get_schema_version;
2110             return if $current_version == $db_version;
2111             die "This module understands schema version $current_version, but database was created with schema version $db_version"
2112             if $db_version > $current_version;
2113             # otherwise we evolve...
2114             my $ok = 1;
2115             for (my $i=$db_version;$i<$current_version;$i++) {
2116             print STDERR "Updating database schema from version $i to version ",$i+1,"...\n";
2117             my $method = "_update_schema_from_${i}_to_".($i+1);
2118             $ok &&= eval{$self->$method};
2119             warn $@ if $@;
2120             }
2121             die "Update failed" unless $ok;
2122             eval {$self->dbh->do($_)} foreach split ';',$self->_variables_table_def;
2123             $self->set_schema_version($self->schema_version);
2124             }
2125              
2126             ###### schema update statements ######
2127              
2128             =head2 $fs->_update_schema_from_A_to_B
2129              
2130             Every update to this library that defines a new schema version has a
2131             series of methods named _update_schema_from_A_to_B(), where A and B are
2132             sequential version numbers. For example, if the current schema version
2133             is 3, then the library will define the following methods:
2134              
2135             $fs->_update_schema_from_1_to_2
2136             $fs->_update_schema_from_2_to_3
2137              
2138             These methods are only of interests to people who want to write
2139             adapters for DBMS engines that are not currently supported, such as
2140             Oracle.
2141              
2142             =cut
2143              
2144             sub _update_schema_from_1_to_2 {
2145             my $self = shift;
2146             my $dbh = $self->dbh;
2147             $dbh->do('alter table metadata change column length size bigint default 0');
2148             $dbh->do($self->_variables_table_def);
2149             1;
2150             }
2151              
2152             sub _update_schema_from_2_to_3 {
2153             my $self = shift;
2154             my $dbh = $self->dbh;
2155             $dbh->do($_) foreach split ';',$self->_xattr_table_def;
2156             1;
2157             }
2158              
2159             sub _variables_table_def {
2160             return <
2161             create table sqlfs_vars (
2162             name varchar(255) primary key,
2163             value varchar(255)
2164             )
2165             END
2166             }
2167              
2168             =Head2 $size = $fs->blocksize
2169              
2170             This method returns the blocksize (currently 4096 bytes) used for
2171             writing and retrieving file contents to the extents table. Because
2172             4096 is a typical value used by libc, altering the value in subclasses
2173             will probably degrade performance. Also be aware that altering the
2174             blocksize will render filesystems created with other blocksize values
2175             unreadable.
2176              
2177             =cut
2178              
2179             sub blocksize { return 4096 }
2180              
2181             =head2 $count = $fs->flushblocks
2182              
2183             This method returns the maximum number of blocks of file contents data
2184             that can be stored in memory before it is written to disk. Because all
2185             blocks are written to the database in a single transaction, this can
2186             have a dramatic performance effect and it is worth trying different
2187             values when tuning the module for new DBMSs.
2188              
2189             The default is 64.
2190              
2191             =cut
2192              
2193             sub flushblocks { return 64 }
2194              
2195              
2196             =head2 $fixed_path = fixup($path)
2197              
2198             This is an ordinary function (not a method!) that removes the initial
2199             slash from paths passed to this module from Fuse. The root directory
2200             (/) is not changed:
2201              
2202             Before After fixup()
2203             ------ -------------
2204             /foo foo
2205             /foo/bar foo/bar
2206             / /
2207              
2208             To call this method from subclasses, invoke it as DBI::Filesystem::fixup().
2209              
2210             =cut
2211              
2212             sub fixup {
2213             my $path = shift;
2214             no warnings;
2215             $path =~ s!^/!!;
2216             $path || '/';
2217             }
2218              
2219             =head2 $dsn = $fs->dsn
2220              
2221             This method returns the DBI data source passed to new(). It cannot be
2222             changed.
2223              
2224             =cut
2225              
2226             sub dsn { shift->{dsn} }
2227              
2228             =head2 $dbh = $fs->dbh
2229              
2230             This method opens a connection to the database defined by dsn() and
2231             returns the database handle (or raises a fatal exception). The
2232             database handle will have its RaiseError and AutoCommit flags set to
2233             true. Since the mount function is multithreaded, there will be one
2234             database handle created per thread.
2235              
2236             =cut
2237              
2238             sub dbh {
2239             my $self = shift;
2240             my $dsn = $self->dsn;
2241             return $self->{dbh} if $self->{dbh};
2242             my $dbh = DBI->connect($dsn,
2243             undef,undef,
2244             {RaiseError=>1,
2245             PrintError=>0,
2246             AutoCommit=>1}) or die DBI->errstr;
2247             $self->_dbh_init($dbh) if $self->can('_dbh_init');
2248             return $self->{dbh}=$dbh;
2249             }
2250              
2251             =head2 $inode = $fs->create_inode($type,$mode,$rdev,$uid,$gid)
2252              
2253             This method creates a new inode in the database. An inode corresponds
2254             to a file, directory, symlink, pipe or block special device, and has a
2255             unique integer ID defining it as its primary key. Arguments are the
2256             type of inode to create, which is used to check that the passed mode
2257             is correct ('f'=file, 'd'=directory,'l'=symlink; anything else is
2258             ignored), the mode of the inode, which is a combination of type and
2259             access permissions as described in stat(2), the device ID if a special
2260             file, and the desired UID and GID.
2261              
2262             The return value is the newly-created inode ID.
2263              
2264             You will ordinarily use the mknod() and mkdir() methods to create
2265             files, directories and special files.
2266              
2267             =cut
2268              
2269             sub create_inode {
2270             my $self = shift;
2271             my ($type,$mode,$rdev,$uid,$gid) = @_;
2272              
2273             $mode ||= 0777; # set filetype unless already set
2274             $mode |= $type eq 'f' ? 0100000
2275             :$type eq 'd' ? 0040000
2276             :$type eq 'l' ? 0120000
2277             :0000000 unless $mode&0777000;
2278              
2279             $uid ||= 0;
2280             $gid ||= 0;
2281             $rdev ||= 0;
2282              
2283             my $dbh = $self->dbh;
2284             my $sth = $dbh->prepare_cached($self->_create_inode_sql);
2285             $sth->execute($mode,$uid,$gid,$rdev,$type eq 'd' ? 1 : 0) or die $sth->errstr;
2286             $sth->finish;
2287             return $self->last_inserted_inode($dbh);
2288             }
2289              
2290             =head2 $id = $fs->last_inserted_inode($dbh)
2291              
2292             After a new inode is inserted into the database, this method returns
2293             its ID. Unique inode IDs are generated using various combinations of
2294             database autoincrement and sequence semantics, which vary from DBMS to
2295             DBMS, so you may need to override this method in subclasses.
2296              
2297             The default is simply to call DBI's last_insert_id method:
2298              
2299             $dbh->last_insert_id(undef,undef,undef,undef)
2300              
2301             =cut
2302              
2303             sub last_inserted_inode {
2304             my $self = shift;
2305             my $dbh = shift;
2306             return $dbh->last_insert_id(undef,undef,undef,undef);
2307             }
2308              
2309             =head2 $self->create_path($inode,$path)
2310              
2311             After creating an inode, you can associate it with a path in the
2312             filesystem using this method. It will raise an error if unsuccessful.
2313              
2314             =cut
2315              
2316             # this links an inode to a path
2317             sub create_path {
2318             my $self = shift;
2319             my ($inode,$path) = @_;
2320              
2321             my $parent = $self->path2inode($self->_dirname($path));
2322             my $base = basename($path);
2323             $base =~ s!/!_!g;
2324              
2325             my $dbh = $self->dbh;
2326             my $sth = $dbh->prepare_cached('insert into path (inode,name,parent) values (?,?,?)');
2327             $sth->execute($inode,$base,$parent);
2328             $sth->finish;
2329              
2330             $dbh->do("update metadata set links=links+1 where inode=$inode");
2331             $dbh->do("update metadata set links=links+1 where inode=$parent");
2332             $self->touch($parent,'ctime');
2333             $self->touch($parent,'mtime');
2334             }
2335              
2336             =head2 $inode=$self->create_inode_and_path($path,$type,$mode,$rdev)
2337              
2338             Create an inode and associate it with the indicated path, returning
2339             the inode ID. Arguments are the path, the file type (one of 'd', 'f',
2340             or 'l' for directory, file or symbolic link). As usual, this may exit
2341             with a fatal error.
2342              
2343             =cut
2344              
2345             sub create_inode_and_path {
2346             my $self = shift;
2347             my ($path,$type,$mode,$rdev) = @_;
2348             my $dbh = $self->dbh;
2349             my $inode;
2350              
2351             my $parent = $self->path2inode($self->_dirname($path));
2352             $self->check_perm($parent,W_OK);
2353              
2354             my $ctx = $self->get_context;
2355              
2356             eval {
2357             $dbh->begin_work;
2358             $inode = $self->create_inode($type,$mode,$rdev,@{$ctx}{'uid','gid'});
2359             $self->create_path($inode,$path);
2360             $dbh->commit;
2361             };
2362             if ($@) {
2363             my $message = $@;
2364             eval{$dbh->rollback()};
2365             die "commit failed due to $message";
2366             }
2367             return $inode;
2368             }
2369              
2370             =head2 $fs->unlink_inode($inode)
2371              
2372             Given an inode, this deletes it and its contents, but only if the file
2373             is no longer in use. It will die with an exception if the changes
2374             cannot be committed to the database.
2375              
2376             =cut
2377              
2378              
2379             sub unlink_inode {
2380             my $self = shift;
2381             my $inode = shift;
2382             my $dbh = $self->dbh;
2383             my ($references) = $dbh->selectrow_array("select links+inuse from metadata where inode=$inode");
2384             return if $references > 0;
2385             eval {
2386             $dbh->begin_work;
2387             $dbh->do("delete from metadata where inode=$inode") or die $dbh->errstr;
2388             $dbh->do("delete from extents where inode=$inode") or die $dbh->errstr;
2389             $dbh->commit;
2390             };
2391             if ($@) {
2392             eval {$dbh->rollback};
2393             die "commit aborted due to $@";
2394             }
2395             }
2396              
2397             =head2 $boolean = $fs->check_path($name,$inode,$uid,$gid)
2398              
2399             Given a directory's name, inode, and the UID and GID of the current
2400             user, this will traverse all containing directories checking that
2401             their execute permissions are set. If the directory and all of its
2402             parents are executable by the current user, then returns true.
2403              
2404             =cut
2405              
2406             # traverse path recursively, checking for X permission
2407             sub check_path {
2408             my $self = shift;
2409             my ($dir,$inode,$uid,$gid) = @_;
2410              
2411             return 1 if $self->ignore_permissions;
2412              
2413             my $groups = $self->get_groups($uid,$gid);
2414              
2415             my $dbh = $self->dbh;
2416             my $sth = $dbh->prepare_cached(<
2417             select p.parent,m.mode,m.uid,m.gid
2418             from path as p,metadata as m
2419             where p.inode=m.inode
2420             and p.inode=? and p.name=?
2421             END
2422             ;
2423             my $name = basename($dir);
2424             my $ok = 1;
2425             while ($ok) {
2426             $sth->execute($inode,$name);
2427             my ($node,$mode,$owner,$group) = $sth->fetchrow_array() or last;
2428             my $mask = $uid==$owner ? S_IXUSR
2429             :$groups->{$group} ? S_IXGRP
2430             :S_IXOTH;
2431             my $allowed = $mask & $mode;
2432             $ok &&= $allowed;
2433             $inode = $node;
2434             $dir = $self->_dirname($dir);
2435             $name = basename($dir);
2436             }
2437             $sth->finish;
2438             return $ok;
2439             }
2440              
2441             =head2 $fs->check_perm($inode,$access_mode)
2442              
2443             Given a file or directory's inode and the access mode (a bitwise OR of
2444             R_OK, W_OK, X_OK), checks whether the current user is allowed
2445             access. This will return if access is allowed, or raise a fatal error
2446             potherwise.
2447              
2448             =cut
2449              
2450             sub check_perm {
2451             my $self = shift;
2452             my ($inode,$access_mode) = @_;
2453              
2454             return 1 if $self->ignore_permissions;
2455              
2456             my $ctx = $self->get_context;
2457             my ($uid,$gid) = @{$ctx}{'uid','gid'};
2458              
2459             return 0 if $uid==0; # root can do anything
2460              
2461             my $dbh = $self->dbh;
2462              
2463             my $fff = 0xfff;
2464             my ($mode,$owner,$group)
2465             = $dbh->selectrow_array("select $fff&mode,uid,gid from metadata where inode=$inode");
2466              
2467             my $groups = $self->get_groups($uid,$gid);
2468             if ($access_mode == F_OK) {
2469             die "permission denied" unless $uid==$owner || $groups->{$group};
2470             return 1;
2471             }
2472              
2473             my $perm_word = $uid==$owner ? $mode >> 6
2474             :$groups->{$group} ? $mode >> 3
2475             :$mode;
2476             $perm_word &= 07;
2477              
2478             $access_mode==($perm_word & $access_mode) or die "permission denied";
2479             return 1;
2480             }
2481              
2482             =head2 $fs->touch($inode,$field)
2483              
2484             This updates the file/directory indicated by $inode to the current
2485             time. $field is one of 'atime', 'ctime' or 'mtime'.
2486              
2487             =cut
2488              
2489             sub touch {
2490             my $self = shift;
2491             my ($inode,$field) = @_;
2492             my $now = $self->_now_sql;
2493             $self->dbh->do("update metadata set $field=$now where inode=$inode");
2494             }
2495              
2496             =head2 $inode = $fs->path2inode($path)
2497              
2498             =head2 ($inode,$parent_inode,$name) = $self->path2inode($path)
2499              
2500             This method takes a filesystem path and transforms it into an inode if
2501             the path is valid. In a scalar context this method return just the
2502             inode. In a list context, it returns a three element list consisting
2503             of the inode, the inode of the containing directory, and the basename
2504             of the file.
2505              
2506             This method does permission and access path checking, and will die
2507             with a "permission denied" error if either check fails. In addition,
2508             passing an invalid path will return a "path not found" error.
2509              
2510             =cut
2511              
2512             # in scalar context return inode
2513             # in list context return (inode,parent_inode,name)
2514             sub path2inode {
2515             my $self = shift;
2516             my $path = shift;
2517              
2518             my $dynamic;
2519             my ($inode,$p_inode,$name) = eval { $self->_path2inode($path)};
2520             unless ($inode) {
2521             ($inode,$p_inode,$name) = $self->_dynamic_path2inode($path);
2522             $dynamic++ if $inode;
2523             }
2524             croak "$path not found" unless $inode;
2525              
2526             my $ctx = $self->get_context;
2527             $self->check_path($self->_dirname($path),$p_inode,@{$ctx}{'uid','gid'}) or die "permission denied";
2528             return wantarray ? ($inode,$p_inode,$name,$dynamic) : $inode;
2529             }
2530              
2531             sub _dynamic_path2inode {
2532             my $self = shift;
2533             my $path = shift;
2534             return unless $self->allow_magic_dirs;
2535             my $dirname = $self->_dirname($path);
2536             my $basename = basename($path);
2537             my ($dir_inode) = $self->_path2inode($dirname) or return;
2538             $self->_is_dynamic_dir($dir_inode,$dirname) or return;
2539             my $entries = $self->get_dynamic_entries($dir_inode,$dirname);
2540             $entries->{$basename} or return;
2541             my ($inode,$parent) = @{$entries->{$basename}};
2542             return ($inode,$parent,$basename);
2543             }
2544              
2545             sub _path2inode {
2546             my $self = shift;
2547             my $path = shift;
2548             if ($path eq '/') {
2549             return wantarray ? (1,undef,'/') : 1;
2550             }
2551             $path =~ s!/$!!;
2552             my ($sql,@bind) = $self->_path2inode_sql($path);
2553             my $dbh = $self->dbh;
2554             my $sth = $dbh->prepare_cached($sql) or croak $dbh->errstr;
2555             $sth->execute(@bind);
2556             my @v = $sth->fetchrow_array() or croak "$path not found";
2557             $sth->finish;
2558             return @v;
2559             }
2560              
2561             =head2 @paths = $fs->inode2paths($inode)
2562              
2563             Given an inode, this method returns the path(s) that correspond to
2564             it. There may be multiple paths since file inodes can have hard
2565             links. In addition, there may be NO path corresponding to an inode, if
2566             the file is open but all externally accessible links have been
2567             unlinked.
2568              
2569             Be aware that the B is indexed to make path to inode
2570             searches fast, not the other way around. If you build a content search
2571             engine on top of DBI::Filesystem and rely on this method, you may wish
2572             to add an index to the path table's "inode" field.
2573              
2574             =cut
2575              
2576             # returns a list of paths that correspond to an inode
2577             # because files can be hardlinked, there may be multiple paths!
2578             sub inode2paths {
2579             my $self = shift;
2580             my $inode = shift;
2581             my $dbh = $self->dbh;
2582             #BUG: inode is not indexed in this table, so this may be slow!
2583             # consider adding an index
2584             my $sth = $dbh->prepare_cached('select name,parent from path where inode=?');
2585             $sth->execute($inode);
2586             my @results;
2587             while (my ($name,$parent) = $sth->fetchrow_array) {
2588             my $directory = $self->_inode2path($parent);
2589             push @results,"$directory/$name";
2590             }
2591             $sth->finish;
2592             return @results;
2593             }
2594              
2595             # recursive walk up the file tree
2596             # this should only be called on directories, as we know
2597             # they do not have hard links
2598             sub _inode2path {
2599             my $self = shift;
2600             my $inode = shift;
2601             return '' if $inode == 1;
2602             my $dbh = $self->dbh;
2603             my ($name,$parent) = $dbh->selectrow_array("select name,parent from path where inode=$inode");
2604             return $self->_inode2path($parent)."/".$name;
2605             }
2606              
2607             sub _dirname {
2608             my $self = shift;
2609             my $path = shift;
2610             my $dir = dirname($path);
2611             $dir = '/' if $dir eq '.'; # work around funniness in dirname()
2612             return $dir;
2613             }
2614              
2615             sub _path2inode_sql {
2616             my $self = shift;
2617             my $path = shift;
2618             my (undef,$dir,$name) = File::Spec->splitpath($path);
2619             my ($parent,@base) = $self->_path2inode_subselect($dir); # something nicely recursive
2620             my $sql = <
2621             select p.inode,p.parent,p.name from metadata as m,path as p
2622             where p.name=? and p.parent in ($parent)
2623             and m.inode=p.inode
2624             END
2625             ;
2626             return ($sql,$name,@base);
2627             }
2628              
2629             sub _path2inode_subselect {
2630             my $self = shift;
2631             my $path = shift;
2632             return 'select 1' if $path eq '/' or !length($path);
2633             $path =~ s!/$!!;
2634             my (undef,$dir,$name) = File::Spec->splitpath($path);
2635             my ($parent,@base) = $self->_path2inode_subselect($dir); # something nicely recursive
2636             return (<
2637             select p.inode from metadata as m,path as p
2638             where p.name=? and p.parent in ($parent)
2639             and m.inode=p.inode
2640             END
2641             ;
2642             }
2643              
2644             =head2 $groups = $fs->get_groups($uid,$gid)
2645              
2646             This method takes a UID and GID, and returns the primary and
2647             supplemental groups to which the user is assigned, and is used during
2648             permission checking. The result is a hashref in which the keys are the
2649             groups to which the user belongs.
2650              
2651             =cut
2652              
2653             sub get_groups {
2654             my $self = shift;
2655             my ($uid,$gid) = @_;
2656             return $self->{_group_cache}{$uid} ||= $self->_get_groups($uid,$gid);
2657             }
2658              
2659             sub _get_groups {
2660             my $self = shift;
2661             my ($uid,$gid) = @_;
2662             my %result;
2663             $result{$gid}++;
2664             my $username = getpwuid($uid) or return \%result;
2665             while (my($name,undef,$id,$members) = getgrent) {
2666             next unless $members =~ /\b$username\b/;
2667             $result{$id}++;
2668             }
2669             endgrent;
2670             return \%result;
2671             }
2672              
2673             =head2 $ctx = $fs->get_context
2674              
2675             This method is a wrapper around the fuse_get_context() function
2676             described in L. If called before the filesystem is mounted, then
2677             it fakes the call, returning a context object based on the information
2678             in the current process.
2679              
2680             =cut
2681              
2682             sub get_context {
2683             my $self = shift;
2684             return fuse_get_context() if $self->mounted;
2685             my ($gid) = $( =~ /^(\d+)/;
2686             return {
2687             uid => $<,
2688             gid => $gid,
2689             pid => $$,
2690             umask => umask()
2691             }
2692             }
2693              
2694             ################# a few SQL fragments; most are inline or in the DBD-specific descendents ######
2695             sub _fgetattr_sql {
2696             my $self = shift;
2697             my $inode = shift;
2698             my $times = join ',',map{$self->_get_unix_timestamp_sql($_)} 'ctime','mtime','atime';
2699             return <
2700             select inode,mode,uid,gid,rdev,links,
2701             $times,size
2702             from metadata
2703             where inode=$inode
2704             END
2705             }
2706              
2707             sub _create_inode_sql {
2708             my $self = shift;
2709             my $now = $self->_now_sql;
2710             return "insert into metadata (mode,uid,gid,rdev,links,mtime,ctime,atime) values(?,?,?,?,?,$now,$now,$now)";
2711             }
2712              
2713              
2714             1;
2715              
2716             =head1 SUBCLASSING
2717              
2718             Subclass this module as you ordinarily would by creating a new package
2719             that has a "use base DBI::Filesystem". You can then tell the
2720             command-line sqlfs.pl tool to load your subclass rather than the
2721             original by providing a --module (or -M) option, as in:
2722              
2723             $ sqlfs.pl -MDBI::Filesystem::MyClass
2724              
2725             =head1 AUTHOR
2726              
2727             Copyright 2013, Lincoln D. Stein
2728              
2729             =head1 LICENSE
2730              
2731             This package is distributed under the terms of the Perl Artistic
2732             License 2.0. See http://www.perlfoundation.org/artistic_license_2_0.
2733              
2734             =cut
2735              
2736             __END__