examples/example.pl
examples/example_t.pl
examples/loopback.pl
-examples/loopback_t.pl
examples/rmount_remote.pl
examples/rmount.pl
-examples/loopback-statvfs.pl
# actually linking the library to itself. Awesome.
package MY;
sub test_via_harness {
- my($self, $perl, $tests) = @_;
- local $_ = $self->SUPER::test_via_harness($perl, $tests);
- s/PERL_DL_NONLAZY=1//g if $^O eq 'darwin';
- return $_;
+ my($self, $perl, $tests) = @_;
+ local $_ = $self->SUPER::test_via_harness($perl, $tests);
+ s/PERL_DL_NONLAZY=1//g if $^O eq 'darwin';
+ return $_;
}
sub test_via_script {
- my($self, $perl, $tests) = @_;
- local $_ = $self->SUPER::test_via_script($perl, $tests);
- s/PERL_DL_NONLAZY=1//g if $^O eq 'darwin';
- return $_;
+ my($self, $perl, $tests) = @_;
+ local $_ = $self->SUPER::test_via_script($perl, $tests);
+ s/PERL_DL_NONLAZY=1//g if $^O eq 'darwin';
+ return $_;
}
package main;
-my $ver = `fusermount -V`;
-my $ver2 = `mount_fusefs -V`;
-chomp(my $ver3 = `mount_fusefs -V 2>&1 | head -n1`);
-$ver =~ s/^.*?version:\s+//;
-$ver2 =~ s/^.*?version:\s+//;
-$ver3 =~ s/^.*?version\s+//;
-if (! $ver && ! $ver2 && ! $ver3) {
- # make CPANPLUS happy and don't report errors if fuse isn't installed
- die("No support for os: $^O\n",
- "You need to have fuse-dev (or similar) package installed and have sufficient permissions in order to install this module\n",
- $^O eq 'darwin' ? ("One option on Mac is http://code.google.com/p/macfuse/\n") : (),
- );
+chomp(my $fusever = `pkg-config --modversion fuse 2> /dev/null`);
+# Required for refuse on NetBSD
+unless ($fusever) {
+ chomp($fusever = `fusermount -V`);
+ $fusever =~ s/^.*?version:\s+//;
}
-if ($ver && $ver + 0 < 2.5) {
- die "Fuse perl bindings need Linux fuse version 2.5 or newer\n";
-} elsif ($ver2 && $ver2 + 0 < 0.3) {
- die "Fuse perl bindings need FreeBSD fuse version 0.3 or newer\n";
-} elsif ($^O eq 'darwin' && $ver3 && !(($ver3 ge "0.1.0b006") || ($ver3 eq "0.1.0"))) {
- # the "ge" string-compare check will match all later revs and all later
- # betas, but not the final release of the current rev (0.1.0).
- die "Fuse perl bindings need MacFUSE version 0.1.0b006 or newer, your version is \"$ver3\"\n";
+
+unless ($fusever) {
+ # make CPANPLUS happy and don't report errors if fuse isn't installed
+ die("No support for os: $^O\n",
+ "You need to have fuse-dev (or similar) package installed and have sufficient permissions in order to install this module\n",
+ $^O eq 'darwin' ? ("One option on Mac is http://code.google.com/p/macfuse/\n") : (),
+ );
+}
+if ($fusever && $fusever + 0 < 2.6) {
+ die "FUSE API is ", $fusever, ", must be 2.6 or later\n";
} else {
- warn "fuse version found: ", $ver || $ver2 || $ver3, "\n";
+ warn "fuse version found: ", $fusever, "\n";
}
-my $inc = '-DFUSE_USE_VERSION=26 ' . `pkg-config --cflags fuse` || '-I ../include -D_FILE_OFFSET_BITS=64';
-my $obj = `pkg-config --libs fuse` || (($^O eq 'netbsd') ? '-lrefuse' : '-lfuse');
+chomp(my $inc = `pkg-config --cflags-only-I fuse 2> /dev/null` || '-I ../include');
+chomp(my $libs = `pkg-config --libs-only-L fuse 2> /dev/null`);
+chomp($libs .= `pkg-config --libs-only-l fuse 2> /dev/null` || (($^O eq 'netbsd') ? '-lrefuse' : '-lfuse'));
if ($^O eq 'darwin' && (uname())[2] =~ /^10\./) {
- $obj =~ s/-lfuse/-lfuse_ino64/;
+ $libs =~ s/-lfuse/-lfuse_ino64/;
}
-my $def = '-Wall -g -ggdb';
-$def .= ' -D__FreeBSD__=10 -D_FILE_OFFSET_BITS=64' if $^O eq 'darwin';
+chomp(my $def = '-Wall -g -ggdb -DFUSE_USE_VERSION=26 ' . `pkg-config --cflags-only-other fuse 2> /dev/null` || '-D_FILE_OFFSET_BITS=64');
+chomp($def .= `pkg-config --libs-only-other fuse 2> /dev/null`);
$def .= ' -DPERL_HAS_64BITINT' if $Config{'use64bitint'};
WriteMakefile(
- 'NAME' => 'Fuse',
- 'VERSION_FROM' => 'Fuse.pm', # finds $VERSION
- 'PREREQ_PM' => {}, # e.g., Module::Name => 1.1
- ($] >= 5.005 ? ## Add these new keywords supported since 5.005
- (ABSTRACT_FROM => 'Fuse.pm', # retrieve abstract from module
- AUTHOR => 'Mark Glines <mark@glines.org>') : ()),
- ($ExtUtils::MakeMaker::VERSION < 6.46 ? () : (
- META_MERGE => {
- resources => {
- bugtracker => 'https://rt.cpan.org/Public/Dist/Display.html?Name=Fuse',
- repository => 'http://github.com/dpavlin/perl-fuse'
- }
- })
- ),
- 'LIBS' => [''], # e.g., '-lm'
- 'DEFINE' => $def, # e.g., '-DHAVE_SOMETHING'
+ 'NAME' => 'Fuse',
+ 'VERSION_FROM' => 'Fuse.pm', # finds $VERSION
+ 'PREREQ_PM' => {}, # e.g., Module::Name => 1.1
+ ($] >= 5.005 ? ## Add these new keywords supported since 5.005
+ (ABSTRACT_FROM => 'Fuse.pm', # retrieve abstract from module
+ AUTHOR => 'Mark Glines <mark@glines.org>') : ()),
+ ($ExtUtils::MakeMaker::VERSION < 6.46 ? () : (
+ META_MERGE => {
+ resources => {
+ bugtracker => 'https://rt.cpan.org/Public/Dist/Display.html?Name=Fuse',
+ repository => 'http://github.com/dpavlin/perl-fuse'
+ },
+ })
+ ),
+ 'LIBS' => '-lpthread ' . $libs, # e.g., '-lm'
+ 'DEFINE' => $def, # e.g., '-DHAVE_SOMETHING'
# Insert -I. if you add *.h files later:
- 'INC' => $inc, # e.g., '-I/usr/include/other'
+ 'INC' => $inc, # e.g., '-I/usr/include/other'
# Un-comment this if you add C files to link with later:
- 'OBJECT' => "$obj Fuse.o -lpthread", # link all the C files too
+ 'OBJECT' => 'Fuse$(OBJ_EXT)', # link all the C files too
);
sub MY::postamble {
- return <<'MAKE_MORE';
+ return <<'MAKE_MORE';
cpan:
make clean
MAKE_MORE
};
+
+# vim: ts=4 ai et hls
This is a pre-production release. It seems to work quite well. In fact, I
can't find any problems with it whatsoever. If you do, I want to know.
-Support for FreeBSD is experimental, so expect tests to fail.
-
INSTALLATION
To install this module type the standard commands as root:
still a bug in librefuse that causes readdir() to only be called once.
We will be addressing this with the appropriate developers in the near
future.
+
+Also note that on NetBSD and FreeBSD, extended attributes do not work. These
+are specifics related to the FUSE implementations on those platforms.
+++ /dev/null
-#!/usr/bin/perl
-
-use strict;
-use blib;
-use Fuse;
-use IO::File;
-use POSIX qw(ENOENT ENOSYS EEXIST EPERM O_RDONLY O_RDWR O_APPEND O_CREAT);
-use Fcntl qw(S_ISBLK S_ISCHR S_ISFIFO SEEK_SET);
-require 'syscall.ph'; # for SYS_mknod and SYS_lchown
-use Filesys::Statvfs;
-
-my $tmp_path = "/tmp/fusetest-" . $ENV{LOGNAME};
-if (! -e $tmp_path) {
- mkdir($tmp_path) || die "can't create $tmp_path: $!";
-}
-
-sub fixup { return $tmp_path . shift }
-
-sub x_getattr {
- my ($file) = fixup(shift);
- my (@list) = lstat($file);
- return -$! unless @list;
- return @list;
-}
-
-sub x_getdir {
- my ($dirname) = fixup(shift);
- unless(opendir(DIRHANDLE,$dirname)) {
- return -ENOENT();
- }
- my (@files) = readdir(DIRHANDLE);
- closedir(DIRHANDLE);
- return (@files, 0);
-}
-
-sub x_open {
- my ($file) = fixup(shift);
- my ($mode) = shift;
- return -$! unless sysopen(FILE,$file,$mode);
- close(FILE);
- return 0;
-}
-
-sub x_read {
- my ($file,$bufsize,$off) = @_;
- my ($rv) = -ENOSYS();
- my ($handle) = new IO::File;
- return -ENOENT() unless -e ($file = fixup($file));
- my ($fsize) = -s $file;
- return -ENOSYS() unless open($handle,$file);
- if(seek($handle,$off,SEEK_SET)) {
- read($handle,$rv,$bufsize);
- }
- return $rv;
-}
-
-sub x_write {
- my ($file,$buf,$off) = @_;
- my ($rv);
- return -ENOENT() unless -e ($file = fixup($file));
- my ($fsize) = -s $file;
- return -ENOSYS() unless open(FILE,'+<',$file);
- if($rv = seek(FILE,$off,SEEK_SET)) {
- $rv = print(FILE $buf);
- }
- $rv = -ENOSYS() unless $rv;
- close(FILE);
- return length($buf);
-}
-
-sub err { return (-shift || -$!) }
-
-sub x_readlink { return readlink(fixup(shift) ); }
-sub x_unlink { return unlink(fixup(shift)) ? 0 : -$!; }
-sub x_rmdir { return err(rmdir(fixup(shift)) ); }
-
-sub x_symlink { print "symlink\n"; return symlink(shift,fixup(shift)) ? 0 : -$!; }
-
-sub x_rename {
- my ($old) = fixup(shift);
- my ($new) = fixup(shift);
- my ($err) = rename($old,$new) ? 0 : -ENOENT();
- return $err;
-}
-sub x_link {
- my ($from) = shift;
- my ($to) = shift;
- print "link $from -> $to\n";
- my ($err) = link(fixup($from),fixup($to)) ? 0 : -$!;
- return $err;
-}
-sub x_chown {
- my ($fn) = fixup(shift);
- print "nonexistent $fn\n" unless -e $fn;
- my ($uid,$gid) = @_;
- # perl's chown() does not chown symlinks, it chowns the symlink's
- # target. it fails when the link's target doesn't exist, because
- # the stat64() syscall fails.
- # this causes error messages when unpacking symlinks in tarballs.
- my ($err) = syscall(&SYS_lchown,$fn,$uid,$gid,$fn) ? -$! : 0;
- return $err;
-}
-sub x_chmod {
- my ($fn) = fixup(shift);
- my ($mode) = shift;
- my ($err) = chmod($mode,$fn) ? 0 : -$!;
- return $err;
-}
-sub x_truncate { return truncate(fixup(shift),shift) ? 0 : -$! ; }
-sub x_utime { return utime($_[1],$_[2],fixup($_[0])) ? 0:-$!; }
-
-sub x_mkdir { my ($name, $perm) = @_; return 0 if mkdir(fixup($name),$perm); return -$!; }
-sub x_rmdir { return 0 if rmdir fixup(shift); return -$!; }
-
-sub x_mknod {
- # since this is called for ALL files, not just devices, I'll do some checks
- # and possibly run the real mknod command.
- my ($file, $modes, $dev) = @_;
- $file = fixup($file);
- $! = 0;
- syscall(&SYS_mknod,$file,$modes,$dev);
- return -$!;
-}
-
-# kludge
-sub x_statfs {
- my $name = fixup(shift);
- my($bsize, $frsize, $blocks, $bfree, $bavail,
- $files, $ffree, $favail, $fsid, $basetype, $flag,
- $namemax, $fstr) = statvfs("/tmp") || return -$!;
- return ($namemax, $files, $ffree, $blocks, $bavail, $bsize);
-}
-
-my ($mountpoint) = "";
-$mountpoint = shift(@ARGV) if @ARGV;
-Fuse::main(
- mountpoint=>$mountpoint,
- getattr =>"main::x_getattr",
- readlink=>"main::x_readlink",
- getdir =>"main::x_getdir",
- mknod =>"main::x_mknod",
- mkdir =>"main::x_mkdir",
- unlink =>"main::x_unlink",
- rmdir =>"main::x_rmdir",
- symlink =>"main::x_symlink",
- rename =>"main::x_rename",
- link =>"main::x_link",
- chmod =>"main::x_chmod",
- chown =>"main::x_chown",
- truncate=>"main::x_truncate",
- utime =>"main::x_utime",
- open =>"main::x_open",
- read =>"main::x_read",
- write =>"main::x_write",
- statfs =>"main::x_statfs",
- threaded=>0,
- debug => 1,
-);
#!/usr/bin/perl -w
use strict;
+use Carp ();
+local $SIG{'__WARN__'} = \&Carp::cluck;
+
+my $has_threads = 0;
+eval {
+ require threads;
+ require threads::shared;
+ 1;
+} and do {
+ $has_threads = 1;
+ threads->import();
+ threads::shared->import();
+};
+
+my $has_Filesys__Statvfs = 0;
+eval {
+ require Filesys::Statvfs;
+ 1;
+} and do {
+ $has_Filesys__Statvfs = 1;
+ Filesys::Statvfs->import();
+};
+
use blib;
use Fuse;
use IO::File;
use POSIX qw(ENOENT ENOSYS EEXIST EPERM O_RDONLY O_RDWR O_APPEND O_CREAT);
use Fcntl qw(S_ISBLK S_ISCHR S_ISFIFO SEEK_SET S_ISREG S_ISFIFO S_IMODE);
+use Getopt::Long;
+
+my %extraopts = ( 'threaded' => 0, 'debug' => 0 );
+my($use_real_statfs, $pidfile);
+GetOptions(
+ 'use-threads' => sub {
+ if ($has_threads) {
+ $extraopts{'threaded'} = 1;
+ }
+ },
+ 'debug' => sub {
+ $extraopts{'debug'} = 1;
+ },
+ 'use-real-statfs' => \$use_real_statfs,
+ 'pidfile=s' => \$pidfile,
+) || die('Error parsing options');
+
my $can_syscall = eval {
- require 'syscall.ph'; # for SYS_mknod and SYS_lchown
+ require 'sys/syscall.ph'; # for SYS_mknod and SYS_lchown
};
if (!$can_syscall && open my $fh, '<', '/usr/include/sys/syscall.h') {
- my %sys = do { local $/ = undef;
- <$fh> =~ m/\#define \s+ (\w+) \s+ (\d+)/gxms;
+ my %sys = do { local $/ = undef;
+ <$fh> =~ m/\#define \s+ (\w+) \s+ (\d+)/gxms;
};
- close $fh;
- if ($sys{SYS_mknod} && $sys{SYS_lchown}) {
- *SYS_mknod = sub { $sys{SYS_mknod} };
- *SYS_lchown = sub { $sys{SYS_lchown} };
- $can_syscall = 1;
- }
+ close $fh;
+ if ($sys{SYS_mknod} && $sys{SYS_lchown}) {
+ *SYS_mknod = sub { $sys{SYS_mknod} };
+ *SYS_lchown = sub { $sys{SYS_lchown} };
+ $can_syscall = 1;
+ }
}
sub fixup { return "/tmp/fusetest-" . $ENV{LOGNAME} . shift }
sub x_getattr {
- my ($file) = fixup(shift);
- my (@list) = lstat($file);
- return -$! unless @list;
- return @list;
+ my ($file) = fixup(shift);
+ my (@list) = lstat($file);
+ return -$! unless @list;
+ return @list;
}
sub x_getdir {
- my ($dirname) = fixup(shift);
- unless(opendir(DIRHANDLE,$dirname)) {
- return -ENOENT();
- }
- my (@files) = readdir(DIRHANDLE);
- closedir(DIRHANDLE);
- return (@files, 0);
+ my ($dirname) = fixup(shift);
+ unless(opendir(DIRHANDLE,$dirname)) {
+ return -ENOENT();
+ }
+ my (@files) = readdir(DIRHANDLE);
+ closedir(DIRHANDLE);
+ return (@files, 0);
}
sub x_open {
- my ($file) = fixup(shift);
- my ($mode) = shift;
- return -$! unless sysopen(FILE,$file,$mode);
- close(FILE);
- return 0;
+ my ($file) = fixup(shift);
+ my ($mode) = shift;
+ return -$! unless sysopen(FILE,$file,$mode);
+ close(FILE);
+ return 0;
}
sub x_read {
- my ($file,$bufsize,$off) = @_;
- my ($rv) = -ENOSYS();
- my ($handle) = new IO::File;
- return -ENOENT() unless -e ($file = fixup($file));
- my ($fsize) = -s $file;
- return -ENOSYS() unless open($handle,$file);
- if(seek($handle,$off,SEEK_SET)) {
- read($handle,$rv,$bufsize);
- }
- return $rv;
+ my ($file,$bufsize,$off) = @_;
+ my ($rv) = -ENOSYS();
+ my ($handle) = new IO::File;
+ return -ENOENT() unless -e ($file = fixup($file));
+ my ($fsize) = -s $file;
+ return -ENOSYS() unless open($handle,$file);
+ if(seek($handle,$off,SEEK_SET)) {
+ read($handle,$rv,$bufsize);
+ }
+ return $rv;
}
sub x_write {
- my ($file,$buf,$off) = @_;
- my ($rv);
- return -ENOENT() unless -e ($file = fixup($file));
- my ($fsize) = -s $file;
- return -ENOSYS() unless open(FILE,'+<',$file);
- if($rv = seek(FILE,$off,SEEK_SET)) {
- $rv = print(FILE $buf);
- }
- $rv = -ENOSYS() unless $rv;
- close(FILE);
- return length($buf);
+ my ($file,$buf,$off) = @_;
+ my ($rv);
+ return -ENOENT() unless -e ($file = fixup($file));
+ my ($fsize) = -s $file;
+ return -ENOSYS() unless open(FILE,'+<',$file);
+ if($rv = seek(FILE,$off,SEEK_SET)) {
+ $rv = print(FILE $buf);
+ }
+ $rv = -ENOSYS() unless $rv;
+ close(FILE);
+ return length($buf);
}
sub err { return (-shift || -$!) }
sub x_symlink { print "symlink\n"; return symlink(shift,fixup(shift)) ? 0 : -$!; }
sub x_rename {
- my ($old) = fixup(shift);
- my ($new) = fixup(shift);
- my ($err) = rename($old,$new) ? 0 : -ENOENT();
- return $err;
+ my ($old) = fixup(shift);
+ my ($new) = fixup(shift);
+ my ($err) = rename($old,$new) ? 0 : -ENOENT();
+ return $err;
}
sub x_link { return link(fixup(shift),fixup(shift)) ? 0 : -$! }
sub x_chown {
- return -ENOSYS() if ! $can_syscall;
- my ($fn) = fixup(shift);
- print "nonexistent $fn\n" unless -e $fn;
- my ($uid,$gid) = @_;
- # perl's chown() does not chown symlinks, it chowns the symlink's
- # target. it fails when the link's target doesn't exist, because
- # the stat64() syscall fails.
- # this causes error messages when unpacking symlinks in tarballs.
- my ($err) = syscall(&SYS_lchown,$fn,$uid,$gid,$fn) ? -$! : 0;
- return $err;
+ return -ENOSYS() if ! $can_syscall;
+ my ($fn) = fixup(shift);
+ print "nonexistent $fn\n" unless -e $fn;
+ my ($uid,$gid) = @_;
+ # perl's chown() does not chown symlinks, it chowns the symlink's
+ # target. it fails when the link's target doesn't exist, because
+ # the stat64() syscall fails.
+ # this causes error messages when unpacking symlinks in tarballs.
+ my ($err) = syscall(&SYS_lchown,$fn,$uid,$gid,$fn) ? -$! : 0;
+ return $err;
}
sub x_chmod {
- my ($fn) = fixup(shift);
- my ($mode) = shift;
- my ($err) = chmod($mode,$fn) ? 0 : -$!;
- return $err;
+ my ($fn) = fixup(shift);
+ my ($mode) = shift;
+ my ($err) = chmod($mode,$fn) ? 0 : -$!;
+ return $err;
}
sub x_truncate { return truncate(fixup(shift),shift) ? 0 : -$! ; }
sub x_utime { return utime($_[1],$_[2],fixup($_[0])) ? 0:-$!; }
sub x_rmdir { return 0 if rmdir fixup(shift); return -$!; }
sub x_mknod {
- return -ENOSYS() if ! $can_syscall;
- # since this is called for ALL files, not just devices, I'll do some checks
- # and possibly run the real mknod command.
- my ($file, $modes, $dev) = @_;
- $file = fixup($file);
- undef $!;
- if ($^O eq 'freebsd' || $^O eq 'darwin' || $^O eq 'netbsd') {
- if (S_ISREG($modes)) {
- open(FILE, '>', $file) || return -$!;
- print FILE "";
- close(FILE);
- return 0;
- } elsif (S_ISFIFO($modes)) {
- my ($rv) = POSIX::mkfifo($file, S_IMODE($modes));
- return $rv ? 0 : -POSIX::errno();
- }
- }
- syscall(&SYS_mknod,$file,$modes,$dev);
- return -$!;
+ return -ENOSYS() if ! $can_syscall;
+ # since this is called for ALL files, not just devices, I'll do some checks
+ # and possibly run the real mknod command.
+ my ($file, $modes, $dev) = @_;
+ $file = fixup($file);
+ undef $!;
+ if ($^O eq 'freebsd' || $^O eq 'darwin' || $^O eq 'netbsd') {
+ if (S_ISREG($modes)) {
+ open(FILE, '>', $file) || return -$!;
+ print FILE '';
+ close(FILE);
+ return 0;
+ } elsif (S_ISFIFO($modes)) {
+ my ($rv) = POSIX::mkfifo($file, S_IMODE($modes));
+ return $rv ? 0 : -POSIX::errno();
+ }
+ }
+ syscall(&SYS_mknod,$file,$modes,$dev);
+ return -$!;
}
# kludge
-sub x_statfs {return 255,1000000,500000,1000000,500000,4096}
-my ($mountpoint) = "";
+sub x_statfs {
+ if ($has_Filesys__Statvfs && $use_real_statfs) {
+ (my($bsize, $frsize, $blocks, $bfree, $bavail,
+ $files, $ffree, $favail, $flag,
+ $namemax) = statvfs('/tmp')) || return -$!;
+ return ($namemax, $files, $ffree, $blocks, $bavail, $bsize);
+ }
+ return 255,1000000,500000,1000000,500000,4096;
+}
+my ($mountpoint) = '';
$mountpoint = shift(@ARGV) if @ARGV;
+
+if (! -d $mountpoint) {
+ print STDERR "ERROR: attempted to mount to non-directory\n";
+ return -&ENOTDIR
+}
+my $pid = fork();
+die("fork() failed: $!") unless defined $pid;
+
+if ($pid > 0) {
+ # parent process
+ exit(0);
+}
+if ($pidfile) {
+ open(PIDFILE, '>', $pidfile);
+ print PIDFILE $$, "\n";
+ close(PIDFILE);
+}
Fuse::main(
- mountpoint=>$mountpoint,
- getattr =>"main::x_getattr",
- readlink=>"main::x_readlink",
- getdir =>"main::x_getdir",
- mknod =>"main::x_mknod",
- mkdir =>"main::x_mkdir",
- unlink =>"main::x_unlink",
- rmdir =>"main::x_rmdir",
- symlink =>"main::x_symlink",
- rename =>"main::x_rename",
- link =>"main::x_link",
- chmod =>"main::x_chmod",
- chown =>"main::x_chown",
- truncate=>"main::x_truncate",
- utime =>"main::x_utime",
- open =>"main::x_open",
- read =>"main::x_read",
- write =>"main::x_write",
- statfs =>"main::x_statfs",
- threaded=>0,
- debug => 1,
+ 'mountpoint' => $mountpoint,
+ 'getattr' => 'main::x_getattr',
+ 'readlink' => 'main::x_readlink',
+ 'getdir' => 'main::x_getdir',
+ 'mknod' => 'main::x_mknod',
+ 'mkdir' => 'main::x_mkdir',
+ 'unlink' => 'main::x_unlink',
+ 'rmdir' => 'main::x_rmdir',
+ 'symlink' => 'main::x_symlink',
+ 'rename' => 'main::x_rename',
+ 'link' => 'main::x_link',
+ 'chmod' => 'main::x_chmod',
+ 'chown' => 'main::x_chown',
+ 'truncate' => 'main::x_truncate',
+ 'utime' => 'main::x_utime',
+ 'open' => 'main::x_open',
+ 'read' => 'main::x_read',
+ 'write' => 'main::x_write',
+ 'statfs' => 'main::x_statfs',
+ %extraopts,
);
+
+# vim: ts=4 ai et hls
+++ /dev/null
-#!/usr/bin/perl -w
-use strict;
-use threads;
-use threads::shared;
-
-use blib;
-use Fuse;
-use IO::File;
-use POSIX qw(ENOENT ENOSYS EEXIST EPERM O_RDONLY O_RDWR O_APPEND O_CREAT);
-use Fcntl qw(S_ISBLK S_ISCHR S_ISFIFO SEEK_SET S_ISREG S_ISFIFO S_IMODE);
-my $can_syscall = eval {
- require 'syscall.ph'; # for SYS_mknod and SYS_lchown
-};
-if (!$can_syscall && open my $fh, '<', '/usr/include/sys/syscall.h') {
- my %sys = do { local $/ = undef;
- <$fh> =~ m/\#define \s+ (\w+) \s+ (\d+)/gxms;
- };
- close $fh;
- if ($sys{SYS_mknod} && $sys{SYS_lchown}) {
- *SYS_mknod = sub { $sys{SYS_mknod} };
- *SYS_lchown = sub { $sys{SYS_lchown} };
- $can_syscall = 1;
- }
-}
-
-sub fixup { return "/tmp/fusetest-" . $ENV{LOGNAME} . shift }
-
-sub x_getattr {
- my ($file) = fixup(shift);
- my (@list) = lstat($file);
- return -$! unless @list;
- return @list;
-}
-
-sub x_getdir {
- my ($dirname) = fixup(shift);
- unless(opendir(DIRHANDLE,$dirname)) {
- return -ENOENT();
- }
- my (@files) = readdir(DIRHANDLE);
- closedir(DIRHANDLE);
- return (@files, 0);
-}
-
-sub x_open {
- my ($file) = fixup(shift);
- my ($mode) = shift;
- return -$! unless sysopen(FILE,$file,$mode);
- close(FILE);
- return 0;
-}
-
-sub x_read {
- my ($file,$bufsize,$off) = @_;
- my ($rv) = -ENOSYS();
- my ($handle) = new IO::File;
- return -ENOENT() unless -e ($file = fixup($file));
- my ($fsize) = -s $file;
- return -ENOSYS() unless open($handle,$file);
- if(seek($handle,$off,SEEK_SET)) {
- read($handle,$rv,$bufsize);
- }
- return $rv;
-}
-
-sub x_write {
- my ($file,$buf,$off) = @_;
- my ($rv);
- return -ENOENT() unless -e ($file = fixup($file));
- my ($fsize) = -s $file;
- return -ENOSYS() unless open(FILE,'+<',$file);
- if($rv = seek(FILE,$off,SEEK_SET)) {
- $rv = print(FILE $buf);
- }
- $rv = -ENOSYS() unless $rv;
- close(FILE);
- return length($buf);
-}
-
-sub err { return (-shift || -$!) }
-
-sub x_readlink { return readlink(fixup(shift)); }
-sub x_unlink { return unlink(fixup(shift)) ? 0 : -$!; }
-
-sub x_symlink { print "symlink\n"; return symlink(shift,fixup(shift)) ? 0 : -$!; }
-
-sub x_rename {
- my ($old) = fixup(shift);
- my ($new) = fixup(shift);
- my ($err) = rename($old,$new) ? 0 : -ENOENT();
- return $err;
-}
-sub x_link { return link(fixup(shift),fixup(shift)) ? 0 : -$! }
-sub x_chown {
- return -ENOSYS() if ! $can_syscall;
- my ($fn) = fixup(shift);
- print "nonexistent $fn\n" unless -e $fn;
- my ($uid,$gid) = @_;
- # perl's chown() does not chown symlinks, it chowns the symlink's
- # target. it fails when the link's target doesn't exist, because
- # the stat64() syscall fails.
- # this causes error messages when unpacking symlinks in tarballs.
- my ($err) = syscall(&SYS_lchown,$fn,$uid,$gid,$fn) ? -$! : 0;
- return $err;
-}
-sub x_chmod {
- my ($fn) = fixup(shift);
- my ($mode) = shift;
- my ($err) = chmod($mode,$fn) ? 0 : -$!;
- return $err;
-}
-sub x_truncate { return truncate(fixup(shift),shift) ? 0 : -$! ; }
-sub x_utime { return utime($_[1],$_[2],fixup($_[0])) ? 0:-$!; }
-
-sub x_mkdir { my ($name, $perm) = @_; return 0 if mkdir(fixup($name),$perm); return -$!; }
-sub x_rmdir { return 0 if rmdir fixup(shift); return -$!; }
-
-sub x_mknod {
- return -ENOSYS() if ! $can_syscall;
- # since this is called for ALL files, not just devices, I'll do some checks
- # and possibly run the real mknod command.
- my ($file, $modes, $dev) = @_;
- $file = fixup($file);
- undef $!;
- if ($^O eq 'freebsd' || $^O eq 'darwin' || $^O eq 'netbsd') {
- if (S_ISREG($modes)) {
- open(FILE, '>', $file) || return -$!;
- print FILE "";
- close(FILE);
- return 0;
- } elsif (S_ISFIFO($modes)) {
- my ($rv) = POSIX::mkfifo($file, S_IMODE($modes));
- return $rv ? 0 : -POSIX::errno();
- }
- }
- syscall(&SYS_mknod,$file,$modes,$dev);
- return -$!;
-}
-
-# kludge
-sub x_statfs {return 255,1000000,500000,1000000,500000,4096}
-my ($mountpoint) = "";
-$mountpoint = shift(@ARGV) if @ARGV;
-Fuse::main(
- mountpoint=>$mountpoint,
- getattr =>"main::x_getattr",
- readlink=>"main::x_readlink",
- getdir =>"main::x_getdir",
- mknod =>"main::x_mknod",
- mkdir =>"main::x_mkdir",
- unlink =>"main::x_unlink",
- rmdir =>"main::x_rmdir",
- symlink =>"main::x_symlink",
- rename =>"main::x_rename",
- link =>"main::x_link",
- chmod =>"main::x_chmod",
- chown =>"main::x_chown",
- truncate=>"main::x_truncate",
- utime =>"main::x_utime",
- open =>"main::x_open",
- read =>"main::x_read",
- write =>"main::x_write",
- statfs =>"main::x_statfs",
- threaded=>1,
-);
use POSIX qw(WEXITSTATUS);
our ($VERSION, @ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS);
@ISA = "Exporter";
-@EXPORT_OK = qw($_loop $_point $_pidfile $_real);
+@EXPORT_OK = qw($_loop $_opts $_point $_pidfile $_real);
my $tmp = -d '/private' ? '/private/tmp' : '/tmp';
-our($_loop, $_point, $_pidfile, $_real) = ("","$tmp/fusemnt-".$ENV{LOGNAME},"test/s/mounted.pid","$tmp/fusetest-".$ENV{LOGNAME});
-#$_loop = $^O ne 'darwin' && $Config{useithreads} ? "examples/loopback_t.pl" : "examples/loopback.pl";
-$_loop = $Config{useithreads} ? "examples/loopback_t.pl" : "examples/loopback.pl";
+our($_loop, $_point, $_pidfile, $_real, $_opts) = ('examples/loopback.pl',"$tmp/fusemnt-".$ENV{LOGNAME},"test/s/mounted.pid","$tmp/fusetest-".$ENV{LOGNAME}, '');
+$_opts = '--pidfile ' . $_pidfile;
+$_opts .= $Config{useithreads} ? ' --use-threads' : '';
if($0 !~ qr|s/u?mount\.t$|) {
my ($reject) = 1;
if(open my $fh, '<', $_pidfile) {
#!/usr/bin/perl -w
-use test::helper qw($_point $_loop $_real $_pidfile);
+use test::helper qw($_point $_loop $_opts $_real $_pidfile);
use strict;
+use Errno qw(:POSIX);
use Test::More tests => 3;
sub is_mounted {
ok(!is_mounted(),"already mounted");
ok(-f $_loop,"loopback exists");
-if(!fork()) {
- #close(STDIN);
- close(STDOUT);
- close(STDERR);
- mkdir $_point;
- mkdir $_real;
- `echo $$ >test/s/mounted.pid`;
- diag "mounting $_loop to $_point";
- open STDOUT, '>', '/tmp/fusemnt.log';
- open STDERR, '>&', \*STDOUT;
- exec("perl -Iblib/lib -Iblib/arch $_loop $_point");
- exit(1);
-}
+mkdir $_point;
+mkdir $_real;
+diag "mounting $_loop to $_point";
+open REALSTDOUT, '>&STDOUT';
+open REALSTDERR, '>&STDERR';
+open STDOUT, '>', '/tmp/fusemnt.log';
+open STDERR, '>&', \*STDOUT;
+system("perl -Iblib/lib -Iblib/arch $_loop $_opts $_point");
+open STDOUT, '>&', \*REALSTDOUT;
+open STDERR, '>&', \*REALSTDERR;
my ($success, $count) = (0,0);
while ($count++ < 50 && !$success) {
use test::helper qw($_real $_point);
use Test::More;
use Config;
+
+my $has_Filesys__Statvfs = 0;
+eval {
+ require Filesys::Statvfs;
+ 1;
+} and do {
+ $has_Filesys__Statvfs = 1;
+ Filesys::Statvfs->import();
+};
+
+my $has_syscall = 0;
eval {
require 'sys/syscall.ph'; # for SYS_statfs
-} or plan skip_all => 'No syscall.ph';
+ 1;
+} and do {
+ $has_syscall = 1;
+};
+
+if (!($has_syscall || $has_Filesys__Statvfs)) {
+ plan skip_all => 'No Filesys::Statvfs and no sys/syscall.ph';
+}
# Maybe not the best way to do this... but it works. Only extract the values
# we care about, so we don't have to worry about changing field ordering
# around and other such nastiness.
my $packmask;
-if ($^O eq 'linux') {
- $packmask = 'x[L!]L![6]x[L]x[L]L';
-}
-elsif ($^O eq 'freebsd') {
- $packmask = 'x[16]Qx[8]Q[2]qQqx[112]Lx[4]';
-}
-elsif ($^O eq 'netbsd') {
- if ($Config{'use64bitint'}) {
- # This should work for any 64-bit NetBSD...
- $packmask = 'x[8]Lx![q]x[16]Q[3]x[8]Q[2]x[64]L';
+# Don't even bother setting up a packmask if we have Filesys::Statvfs.
+# In that case, we can just make one call, and save ourselves a ton of
+# messing around.
+if (!$has_Filesys__Statvfs) {
+ if ($^O eq 'linux') {
+ $packmask = 'x[L!]L![6]x[L]x[L]L';
}
- else {
- # NetBSD's perl on 32-bit doesn't handle quadword types, and
- # this is my workaround. Ugly, but it does the job. And yes,
- # won't work for big values. Good thing we're not testing
- # with any, huh?
- if ($Config{'byteorder'} eq '1234') { # little endian
- $packmask = 'x[4]Lx[8]Lx[4]Lx[4]Lx[4]x[8]Lx[4]Lx[4]x[64]L';
- }
- elsif ($Config{'byteorder'} eq '4321') { # big endian
- $packmask = 'x[4]Lx[8]x[4]Lx[4]Lx[4]Lx[8]x[4]Lx[4]Lx[64]L';
+ elsif ($^O eq 'freebsd') {
+ $packmask = 'x[16]Qx[8]Q[2]qQqx[112]Lx[4]';
+ }
+ elsif ($^O eq 'netbsd') {
+ if ($Config{'use64bitint'}) {
+ # This should work for any 64-bit NetBSD...
+ $packmask = 'x[8]Lx![q]x[16]Q[3]x[8]Q[2]x[64]L';
}
else {
- plan skip_all => "Word ordering not known, don't know how to handle statvfs1()";
- exit(1);
+ # NetBSD's perl on 32-bit doesn't handle quadword types, and
+ # this is my workaround. Ugly, but it does the job. And yes,
+ # won't work for big values. Good thing we're not testing
+ # with any, huh?
+ if ($Config{'byteorder'} eq '1234') { # little endian
+ $packmask = 'x[4]Lx[8]Lx[4]Lx[4]Lx[4]x[8]Lx[4]Lx[4]x[64]L';
+ }
+ elsif ($Config{'byteorder'} eq '4321') { # big endian
+ $packmask = 'x[4]Lx[8]x[4]Lx[4]Lx[4]Lx[8]x[4]Lx[4]Lx[64]L';
+ }
+ else {
+ plan skip_all => "Word ordering not known, don't know how to handle statvfs1()";
+ exit(1);
+ }
}
}
-}
-elsif ($^O eq 'darwin') {
- # Accurate for OS X 10.6; 10.5 and earlier may not actually correspond
- # to this, if my understanding of statfs(2) on OS X is fair.
- $packmask = 'x[L!]L!x[L!]L![5]';
-} else {
- plan skip_all => 'Platform not known, need to know how to statfs';
- exit(1);
+ elsif ($^O eq 'darwin') {
+ # Accurate for OS X 10.6; 10.5 and earlier may not actually correspond
+ # to this, if my understanding of statfs(2) on OS X is fair.
+ $packmask = 'x[L!]L!x[L!]L![5]';
+ }
+ else {
+ plan skip_all => 'Platform not known, need to know how to statfs';
+ exit(1);
+ }
}
if ($^O eq 'netbsd' || $^O eq 'darwin') {
else {
plan tests => 7;
}
-# Just make the buffer large enough that we don't have to care...
-my ($statfs_data) = "\0" x 4096;
-my ($tmp) = $_point;
-if ($^O eq 'netbsd') {
- # NetBSD doesn't have statfs(2); statvfs1(2) is its closest analogue.
- ok(!syscall(&SYS_statvfs1,$tmp,$statfs_data,1),'statvfs1');
+my @list;
+if ($has_Filesys__Statvfs) {
+ # This is a neater way to do this - if it's available...
+ ok(@list = (statvfs($_point))[1,2,3,4,5,6,9]);
}
-else {
- ok(!syscall(&SYS_statfs,$tmp,$statfs_data),'statfs');
+elsif ($has_syscall) {
+ # Just make the buffer large enough that we don't have to care...
+ my ($statfs_data) = "\0" x 4096;
+ my ($tmp) = $_point;
+ if ($^O eq 'netbsd') {
+ # NetBSD doesn't have statfs(2); statvfs1(2) is its closest analogue.
+ ok(!syscall(&SYS_statvfs1,$tmp,$statfs_data,1),'statvfs1');
+ }
+ else {
+ ok(!syscall(&SYS_statfs,$tmp,$statfs_data),'statfs');
+ }
+ @list = unpack($packmask,$statfs_data);
}
-my @list = unpack($packmask,$statfs_data);
diag "statfs: ",join(', ', @list);
is(shift(@list),4096,'block size');
is(shift(@list),1000000,'blocks');
projects / perl-fuse.git / commitdiff