perl-llin/examples/loopback.pl

#!/usr/bin/perl -w
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);
my $can_syscall = eval {
        require 'syscall.ph'; # for SYS_mknod and SYS_lchown
};
if (!$can_syscall && open my $fh, '<', '/usr/include/sys/syscall.h') {
        local $/ = undef;
        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;
        }
}

my $tmp = -d '/private' ? '/private/tmp' : '/tmp';
my $tmp_path = "$tmp/fusetest-" . $ENV{LOGNAME};
if (! -e $tmp_path) {
        mkdir($tmp_path) || die "can't create $tmp_path: $!";
}

sub fixup { print STDERR "fixup $_[0] from @{[caller]}\n";
            my ($path) = @_;
            return $tmp_path if $path eq '/';
            return $tmp_path . $path;
}

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);
        $! = 0;
        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=>0,
        debug => 1,
);
1	dpavlin	18	#!/usr/bin/perl -w
2	dpavlin	19	use strict;
3	mszeredi	4
4	dpavlin	23	use blib;
5	mszeredi	4	use Fuse;
6			use IO::File;
7			use POSIX qw(ENOENT ENOSYS EEXIST EPERM O_RDONLY O_RDWR O_APPEND O_CREAT);
8			use Fcntl qw(S_ISBLK S_ISCHR S_ISFIFO SEEK_SET);
9	dpavlin	112	my $can_syscall = eval {
10			require 'syscall.ph'; # for SYS_mknod and SYS_lchown
11			};
12			if (!$can_syscall && open my $fh, '<', '/usr/include/sys/syscall.h') {
13			local $/ = undef;
14			my %sys = do { local $/ = undef;
15			<$fh> =~ m/\#define \s+ (\w+) \s+ (\d+)/gxms;
16			};
17			close $fh;
18			if ($sys{SYS_mknod} && $sys{SYS_lchown}) {
19			*SYS_mknod = sub { $sys{SYS_mknod} };
20			*SYS_lchown = sub { $sys{SYS_lchown} };
21			$can_syscall = 1;
22			}
23			}
24	mszeredi	4
25	dpavlin	112	my $tmp = -d '/private' ? '/private/tmp' : '/tmp';
26			my $tmp_path = "$tmp/fusetest-" . $ENV{LOGNAME};
27	dpavlin	23	if (! -e $tmp_path) {
28			mkdir($tmp_path) \|\| die "can't create $tmp_path: $!";
29			}
30	mszeredi	4
31	dpavlin	112	sub fixup { print STDERR "fixup $_[0] from @{[caller]}\n";
32			my ($path) = @_;
33			return $tmp_path if $path eq '/';
34			return $tmp_path . $path;
35			}
36	dpavlin	23
37	mszeredi	4	sub x_getattr {
38			my ($file) = fixup(shift);
39			my (@list) = lstat($file);
40			return -$! unless @list;
41			return @list;
42			}
43
44			sub x_getdir {
45			my ($dirname) = fixup(shift);
46			unless(opendir(DIRHANDLE,$dirname)) {
47			return -ENOENT();
48			}
49			my (@files) = readdir(DIRHANDLE);
50			closedir(DIRHANDLE);
51			return (@files, 0);
52			}
53
54			sub x_open {
55			my ($file) = fixup(shift);
56			my ($mode) = shift;
57			return -$! unless sysopen(FILE,$file,$mode);
58			close(FILE);
59			return 0;
60			}
61
62			sub x_read {
63			my ($file,$bufsize,$off) = @_;
64			my ($rv) = -ENOSYS();
65			my ($handle) = new IO::File;
66			return -ENOENT() unless -e ($file = fixup($file));
67			my ($fsize) = -s $file;
68			return -ENOSYS() unless open($handle,$file);
69			if(seek($handle,$off,SEEK_SET)) {
70			read($handle,$rv,$bufsize);
71			}
72			return $rv;
73			}
74
75			sub x_write {
76			my ($file,$buf,$off) = @_;
77			my ($rv);
78			return -ENOENT() unless -e ($file = fixup($file));
79			my ($fsize) = -s $file;
80			return -ENOSYS() unless open(FILE,'+<',$file);
81			if($rv = seek(FILE,$off,SEEK_SET)) {
82			$rv = print(FILE $buf);
83			}
84			$rv = -ENOSYS() unless $rv;
85			close(FILE);
86			return length($buf);
87			}
88
89			sub err { return (-shift \|\| -$!) }
90
91	dpavlin	18	sub x_readlink { return readlink(fixup(shift)); }
92			sub x_unlink { return unlink(fixup(shift)) ? 0 : -$!; }
93	mszeredi	4
94			sub x_symlink { print "symlink\n"; return symlink(shift,fixup(shift)) ? 0 : -$!; }
95
96			sub x_rename {
97			my ($old) = fixup(shift);
98			my ($new) = fixup(shift);
99			my ($err) = rename($old,$new) ? 0 : -ENOENT();
100			return $err;
101			}
102			sub x_link { return link(fixup(shift),fixup(shift)) ? 0 : -$! }
103			sub x_chown {
104	dpavlin	112	return -ENOSYS() if ! $can_syscall;
105	mszeredi	4	my ($fn) = fixup(shift);
106			print "nonexistent $fn\n" unless -e $fn;
107			my ($uid,$gid) = @_;
108			# perl's chown() does not chown symlinks, it chowns the symlink's
109			# target. it fails when the link's target doesn't exist, because
110			# the stat64() syscall fails.
111			# this causes error messages when unpacking symlinks in tarballs.
112			my ($err) = syscall(&SYS_lchown,$fn,$uid,$gid,$fn) ? -$! : 0;
113			return $err;
114			}
115			sub x_chmod {
116			my ($fn) = fixup(shift);
117			my ($mode) = shift;
118			my ($err) = chmod($mode,$fn) ? 0 : -$!;
119			return $err;
120			}
121			sub x_truncate { return truncate(fixup(shift),shift) ? 0 : -$! ; }
122			sub x_utime { return utime($_[1],$_[2],fixup($_[0])) ? 0:-$!; }
123
124			sub x_mkdir { my ($name, $perm) = @_; return 0 if mkdir(fixup($name),$perm); return -$!; }
125			sub x_rmdir { return 0 if rmdir fixup(shift); return -$!; }
126
127			sub x_mknod {
128	dpavlin	112	return -ENOSYS() if ! $can_syscall;
129	mszeredi	4	# since this is called for ALL files, not just devices, I'll do some checks
130			# and possibly run the real mknod command.
131			my ($file, $modes, $dev) = @_;
132			$file = fixup($file);
133			$! = 0;
134			syscall(&SYS_mknod,$file,$modes,$dev);
135			return -$!;
136			}
137
138			# kludge
139			sub x_statfs {return 255,1000000,500000,1000000,500000,4096}
140			my ($mountpoint) = "";
141			$mountpoint = shift(@ARGV) if @ARGV;
142			Fuse::main(
143			mountpoint=>$mountpoint,
144	dpavlin	18	getattr =>"main::x_getattr",
145			readlink=>"main::x_readlink",
146			getdir =>"main::x_getdir",
147			mknod =>"main::x_mknod",
148			mkdir =>"main::x_mkdir",
149			unlink =>"main::x_unlink",
150			rmdir =>"main::x_rmdir",
151			symlink =>"main::x_symlink",
152			rename =>"main::x_rename",
153			link =>"main::x_link",
154			chmod =>"main::x_chmod",
155			chown =>"main::x_chown",
156			truncate=>"main::x_truncate",
157			utime =>"main::x_utime",
158			open =>"main::x_open",
159			read =>"main::x_read",
160			write =>"main::x_write",
161			statfs =>"main::x_statfs",
162			threaded=>0,
163	dpavlin	23	debug => 1,
164	mszeredi	4	);