viewvc.cgi/fuse-comp/fuse-comp.pl

#!/usr/bin/perl -w
use strict;
use threads;
use threads::shared;

use Fuse;
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 PerlIO::gzip;
use File::Path;
use Data::Dump qw/dump/;
use Carp qw/confess/;
use IO::File;
use Getopt::Long;

my $debug = 0;
my $fuse_debug = 0;

GetOptions(
        'debug+' => \$debug,
        'fuse-debug+' => \$fuse_debug,
);

my $mount = {
        from    => '/tmp/comp',
        to              => '/tmp/no-comp',
        tmp             => '/dev/shm/comp',
};

my $skip_extensions_regex = qr/\.(?:sw[a-z]|gif|png|jpeg|jpg|avi|rar|zip|bz2|gz|tgz|avi|mpeg|mpg|tmp|temp)$/i;

# don't compress files smaller than this
my $min_compress_size = 512;

foreach my $dir ( keys %$mount ) {
        if ( ! -e $mount->{$dir} ) {
                warn "created $mount->{$dir}\n";
                mkdir $mount->{$dir} || die "can't create $mount->{$dir}: $!";
        }
}

my $pending;

sub fixup {
        my ( $path ) = @_;
        my $full = $mount->{from} . '/' . $path;
        if ( -e $full . '.gz' ) {
                return $full . '.gz';
        }
        return $full;
}

sub original_name {
        my $p = shift;
        $p =~ s/\.gz$//;
        return $p;
};

sub gzip_original_size {
        my $file = shift;

        return unless -e $file;

        my $buff;

        open(my $fh, $file) || die "can't open $file: $!";

#       read($fh, $buff, 10 );
#       print dump( unpack("nccVcc", $buff ) );

        seek($fh, -4, 2);
        read($fh, $buff, 4 );
        close($fh);

        return unpack("L", $buff);
}

sub x_getattr {
        my ($file) = fixup(shift);
        my (@list) = lstat($file);
        $list[7] = gzip_original_size( $file ) if ( $list[7] && $file =~ m/\.gz$/ );
        return -$! unless @list;
        return @list;
}

sub x_getdir {
        my ($dirname) = fixup(shift);
        unless(opendir(DIRHANDLE,$dirname)) {
                return -ENOENT();
        }
        my @files = map { original_name( $_ ) } readdir(DIRHANDLE);
        closedir(DIRHANDLE);
        return (@files, 0);
}

sub file_copy {
        my ( $s_opt, $s_path, $d_opt, $d_path ) = @_;
        warn "## file_copy( $s_opt $s_path [",-s $s_path,"] $d_opt $d_path [",-e $d_path ? -s $d_path : 'new',"])\n" if $debug;
        open(my $s, $s_opt, $s_path ) || confess "can't open $s_path: $!\npending = ", dump( $pending );
        open(my $d, $d_opt, $d_path ) || confess "can't open $d_path: $!";
        my $buff;
        while( read( $s, $buff, 65535 ) ) {
                print $d $buff || confess "can't write into $d_path: $!";
                warn ">> [", length($buff), "] offset ", tell($s), " -> ", tell($d), "\n" if $debug;
        }
        close($d) || warn "can't close $d_path: $!";
        close($s) || warn "can't close $s_path: $!";
        warn "-- $s_path [", -s $s_path, "] >>> $d_path [", -s $d_path, "]\n" if $debug;
        my ($mode,$uid,$gid,$atime,$mtime) = (stat $s_path)[2,4,5,8,9];

        chmod $mode, $d_path || warn "chmod( $mode $d_path ) failed: $!\n";
        chown $uid,$gid,$d_path || warn "chown( $uid $gid $d_path ) failed: $!\n";
        utime $atime,$mtime,$d_path || warn "utime( $atime $mtime $d_path ) failed: $!\n";

        undef $d;
        undef $s;
}

sub x_open {
        my ($file) = shift;
        my ($mode) = shift;

        if ( $file eq '/.debug' ) {
                my $path = $mount->{from} . '/.debug';
                open( my $debug, '>', $path ) || die "can't open $path: $!";
                my $dump = dump( $pending );
                print $debug "pending = $dump\n";
                close($debug);
                $pending->{'/.debug'}->{path} = $path;
                warn "## created dump $path $dump\n";
                return 0;
        }

        $pending->{$file}->{open}++;

        my $mode_desc = {
                rdonly => $mode && O_RDONLY,
                rdwr => $mode && O_RDWR,
                append => $mode && O_APPEND,
                create => $mode && O_CREAT,
                trunc => $mode && O_TRUNC,
        };
        my $path = fixup($file);
        warn "## open( $file, $mode ) pending: ", $pending->{$file}->{open}, " mode $mode: ", dump( $mode_desc )," $path [", -s $path, "]\n" if $debug;
        my $fh;

        my $tmp = $mount->{tmp} . '/' . $file;
        if ( -e $tmp ) {
                $path = $tmp;
        } elsif ( $path =~ m/\.gz$/ ) {
                my $dest_path = $tmp;
                $dest_path =~ s!/[^/]+$!!;      #!vim-fix
                mkpath $dest_path unless -e $dest_path;
                if ( -s $path ) {
                        file_copy( '<:gzip', $path, '>', $tmp )
                } else {
                        warn "ERROR: filesystem corruption, $path is zero size\n";
                }
                $path = $tmp;
        }

        if ( sysopen($fh , $path, $mode) ) {
                close($fh) || confess "can't close $path: $!";
                warn "<<< open $path [", -e $path ? -s $path : 'new' , "]\n";
                $pending->{$file}->{path} = $path;
                return 0;
        } else {
                warn "ERROR: can't open $path -- $!";
                return -$!;
        }

}

sub x_read {
        my ($file,$bufsize,$off) = @_;
        my ($rv) = -ENOSYS();
        my $path = fixup( $file );

        confess "no pending file $file ", dump( $pending ) unless defined( $pending->{$file} );

        return -ENOENT() unless -e $path;

        my $fh = new IO::File;
        return -ENOSYS() unless open($fh,$pending->{$file}->{path});

        if(seek($fh,$off,SEEK_SET)) {
                read($fh,$rv,$bufsize);
        }

        return $rv;
}

sub x_write {
        my ($file,$buf,$off) = @_;

        my $rv;
        my $path = fixup($file);

        confess "no pending file $file ", dump( $pending ) unless defined( $pending->{$file} );

        return -ENOENT() unless -e $path;

        $path = $pending->{$file}->{path} || confess "no path for $file in ", dump( $pending );
        confess "write into non-existant $path for $file: $!" unless -e $path;

        my $fh = new IO::File;
        return -ENOSYS() unless open($fh,'+<',$path);
        if($rv = seek( $fh ,$off,SEEK_SET)) {
                $rv = print( $fh $buf );
                warn "## write $path offset $off [",length( $buf ), "]\n" if $debug;
                $pending->{$file}->{write}++;
        }
        $rv = -ENOSYS() unless $rv;
        close($fh) || warn "can't close $path: $!";
        return length($buf);
}

sub err { return (-shift || -$!) }

sub x_readlink { return readlink(fixup(shift));         }
sub x_unlink   {
        my $file = shift;
        my $path = fixup( $file );

        if ( $file =~ m#\Q/.fuse_hidden\E# ) {
                return unlink $path ? 0 : -$1;
        }

        warn "# unlink( $file )\n";

        unlink $path || return 0;

        my $tmp = $mount->{tmp} . '/' . $file;
        unlink $tmp if ( -e $tmp );

        delete( $pending->{$file} );
        return 0;
}

sub x_symlink { return symlink(shift,fixup(shift)) ? 0 : -$!; }

sub x_rename {
        my ($old,$new) = @_;
        my $old_path = fixup($old);
        my $new_path = fixup($new);
        $new_path .= '.gz' if ( $old_path =~ m/\.gz$/ && $new_path !~ m/\.gz$/ );

        my $err = rename($old_path,$new_path) ? 0 : -ENOENT();
        warn "## rename( $old_path => $new_path ) = $err\n";

        my $tmp = $mount->{tmp} . '/' . $old;
        if ( -e $tmp ) {
                if ( $new =~ m#\Q/.fuse_hidden\E# ) {
                        unlink $tmp || confess "can't unlink $tmp for $new\n";
                } else {
                        my $new_tmp = $mount->{tmp} . '/' . $new;
                        rename $tmp, $new_tmp || confess "can't rename $tmp -> $new_tmp : $!";
                }
        }

        if (defined( $pending->{$old} )) {
                $pending->{$new} = $pending->{$old};

                my $path = $pending->{$old}->{path};
                $path =~ s/\Q$old\E/$new/;
                $pending->{$new}->{path} = $path;

                delete( $pending->{$old} );
                warn "## tweaking pending to ", dump( $pending ) if $debug;
        }

        return $err;
}
sub x_link { return link(fixup(shift),fixup(shift)) ? 0 : -$! }

sub x_chown {
        my ($file,$uid,$gid) = @_;
        my $path = fixup($file);
        print "nonexistent $path\n" unless -e $path;
        # 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,$path,$uid,$gid,$path) ? -$! : 0;

        my $tmp = $mount->{tmp} . '/' . $file;
        syscall(&SYS_lchown,$file,$uid,$gid,$path) if -e $tmp;

        return $err;
}

sub x_chmod {
        my ($path) = fixup(shift);
        my ($mode) = shift;
        my ($err) = chmod($mode,$path) ? 0 : -$!;
        return $err;
}

sub x_truncate {
        my ( $file,$size ) = @_;
        my $path = fixup($file);
        my $rv = truncate( $path, $size ) ? 0 : -$! ;
        if ( $path =~ m/\.gz$/ ) {
                my $no_gz = $path;
                $no_gz =~ s/\.gz$//;
                rename $path, $no_gz || confess "can't rename $path -> $no_gz: $!";
        }
        warn "## truncate( $file $size ) $path [", -s $path, "] = $rv\n" if $debug;
        $pending->{$file}->{write}++;
        return $rv;
}
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 -$!;
}

sub x_release {
        my ( $file, $mode ) = @_;

        if ( $file =~ m#\Q/.fuse_hidden\E# ) {
                warn "release internal $file\n" if $debug;
                delete( $pending->{$file} );
                return 0;
        }

        if ( ! defined( $pending->{$file} ) ) {
                warn "release $file, NO PENDING DATA\n";
                return 0;
        } elsif ( ! defined( $pending->{$file}->{write} ) ) {
                warn "release $file, not written into\n";
        } elsif ( defined( $pending->{$file}->{open} ) && $pending->{$file}->{open} == 1 ) {
                my $path = $pending->{$file}->{path} || confess "no path for $file ? ", dump( $pending );
                my $dest = fixup( $file );

                # cleanup old compressed copy
                if ( $dest =~ /\.gz$/ ) {
                        warn "## remove old $dest\n";
                        unlink $dest || confess "can't remove $dest: $!";
                        $dest =~ s/\.gz$//;
                }

                if ( $file =~ $skip_extensions_regex ) {
                        warn "release $file [",-s $path,"] skipped compression\n";
                        file_copy( '<', $path, '>', $dest ) if ( $path ne $dest );
                } elsif ( -s $path < $min_compress_size ) {
                        warn "release $file [",-s $path,"] uncompressed, too small\n";
                        file_copy( '<', $path, '>', $dest ) if ( $path ne $dest );
                } else {
                        warn "release $file [",-s $path,"] compressing\n";

                        my $comp = $dest . '.gz';
                        file_copy( '<', $path, '>:gzip', $comp );

                        my ( $size_path, $size_comp ) = ( -s $path, -s $comp );

                        if ( $size_path <= $size_comp ) {
                                warn ">>> $size_path <= $size_comp leaving uncompressed\n";
                                unlink $comp || warn "can't reamove: $comp: $!";
                        } else {
                                warn ">>> compressed $size_path -> $size_comp ",int(($size_comp * 100) / $size_path),"%\n";
                                # FIXME add timeout to remove uncompressed version?
                                unlink $path || warn "can't remove $path: $!";
                        }
                }
        } else {
                warn "release $file, but still used ", $pending->{$file}->{open} , " times, delaying compression\n";
        }
        $pending->{$file}->{open}--;
        if ( $pending->{$file}->{open} == 0 ) {
                warn "## cleanup pending $file [", -s fixup($file), "]\n" if $debug;
                delete( $pending->{$file} );
        }
        return 0;
}

# kludge
sub x_statfs {return 255,1000000,500000,1000000,500000,4096}
Fuse::main(
        mountpoint=>$mount->{to},
        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",
        release =>"main::x_release",
#       threaded=>1,
        debug   => $fuse_debug,
);
1	dpavlin	1	#!/usr/bin/perl -w
2			use strict;
3			use threads;
4			use threads::shared;
5
6			use Fuse;
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			require 'syscall.ph'; # for SYS_mknod and SYS_lchown
10			use PerlIO::gzip;
11			use File::Path;
12			use Data::Dump qw/dump/;
13	dpavlin	5	use Carp qw/confess/;
14	dpavlin	10	use IO::File;
15	dpavlin	23	use Getopt::Long;
16	dpavlin	1
17	dpavlin	23	my $debug = 0;
18			my $fuse_debug = 0;
19
20			GetOptions(
21			'debug+' => \$debug,
22			'fuse-debug+' => \$fuse_debug,
23			);
24
25	dpavlin	1	my $mount = {
26			from => '/tmp/comp',
27			to => '/tmp/no-comp',
28			tmp => '/dev/shm/comp',
29			};
30
31	dpavlin	4	my $skip_extensions_regex = qr/\.(?:sw[a-z]\|gif\|png\|jpeg\|jpg\|avi\|rar\|zip\|bz2\|gz\|tgz\|avi\|mpeg\|mpg\|tmp\|temp)$/i;
32	dpavlin	1
33	dpavlin	5	# don't compress files smaller than this
34	dpavlin	8	my $min_compress_size = 512;
35	dpavlin	5
36	dpavlin	1	foreach my $dir ( keys %$mount ) {
37			if ( ! -e $mount->{$dir} ) {
38			warn "created $mount->{$dir}\n";
39			mkdir $mount->{$dir} \|\| die "can't create $mount->{$dir}: $!";
40			}
41			}
42
43			my $pending;
44
45			sub fixup {
46			my ( $path ) = @_;
47			my $full = $mount->{from} . '/' . $path;
48			if ( -e $full . '.gz' ) {
49			return $full . '.gz';
50			}
51			return $full;
52			}
53
54			sub original_name {
55			my $p = shift;
56			$p =~ s/\.gz$//;
57			return $p;
58			};
59
60			sub gzip_original_size {
61			my $file = shift;
62
63			return unless -e $file;
64
65			my $buff;
66
67			open(my $fh, $file) \|\| die "can't open $file: $!";
68
69			# read($fh, $buff, 10 );
70			# print dump( unpack("nccVcc", $buff ) );
71
72			seek($fh, -4, 2);
73			read($fh, $buff, 4 );
74			close($fh);
75
76			return unpack("L", $buff);
77			}
78
79			sub x_getattr {
80			my ($file) = fixup(shift);
81			my (@list) = lstat($file);
82			$list[7] = gzip_original_size( $file ) if ( $list[7] && $file =~ m/\.gz$/ );
83			return -$! unless @list;
84			return @list;
85			}
86
87			sub x_getdir {
88			my ($dirname) = fixup(shift);
89			unless(opendir(DIRHANDLE,$dirname)) {
90			return -ENOENT();
91			}
92			my @files = map { original_name( $_ ) } readdir(DIRHANDLE);
93			closedir(DIRHANDLE);
94			return (@files, 0);
95			}
96
97			sub file_copy {
98			my ( $s_opt, $s_path, $d_opt, $d_path ) = @_;
99	dpavlin	19	warn "## file_copy( $s_opt $s_path [",-s $s_path,"] $d_opt $d_path [",-e $d_path ? -s $d_path : 'new',"])\n" if $debug;
100	dpavlin	5	open(my $s, $s_opt, $s_path ) \|\| confess "can't open $s_path: $!\npending = ", dump( $pending );
101			open(my $d, $d_opt, $d_path ) \|\| confess "can't open $d_path: $!";
102	dpavlin	1	my $buff;
103			while( read( $s, $buff, 65535 ) ) {
104	dpavlin	5	print $d $buff \|\| confess "can't write into $d_path: $!";
105	dpavlin	13	warn ">> [", length($buff), "] offset ", tell($s), " -> ", tell($d), "\n" if $debug;
106	dpavlin	1	}
107			close($d) \|\| warn "can't close $d_path: $!";
108			close($s) \|\| warn "can't close $s_path: $!";
109	dpavlin	5	warn "-- $s_path [", -s $s_path, "] >>> $d_path [", -s $d_path, "]\n" if $debug;
110			my ($mode,$uid,$gid,$atime,$mtime) = (stat $s_path)[2,4,5,8,9];
111
112			chmod $mode, $d_path \|\| warn "chmod( $mode $d_path ) failed: $!\n";
113			chown $uid,$gid,$d_path \|\| warn "chown( $uid $gid $d_path ) failed: $!\n";
114			utime $atime,$mtime,$d_path \|\| warn "utime( $atime $mtime $d_path ) failed: $!\n";
115	dpavlin	8
116			undef $d;
117			undef $s;
118	dpavlin	1	}
119
120			sub x_open {
121			my ($file) = shift;
122			my ($mode) = shift;
123	dpavlin	12
124			if ( $file eq '/.debug' ) {
125			my $path = $mount->{from} . '/.debug';
126			open( my $debug, '>', $path ) \|\| die "can't open $path: $!";
127			my $dump = dump( $pending );
128			print $debug "pending = $dump\n";
129			close($debug);
130			$pending->{'/.debug'}->{path} = $path;
131			warn "## created dump $path $dump\n";
132			return 0;
133			}
134
135	dpavlin	1	$pending->{$file}->{open}++;
136	dpavlin	8
137			my $mode_desc = {
138			rdonly => $mode && O_RDONLY,
139			rdwr => $mode && O_RDWR,
140			append => $mode && O_APPEND,
141			create => $mode && O_CREAT,
142	dpavlin	14	trunc => $mode && O_TRUNC,
143	dpavlin	8	};
144	dpavlin	14	my $path = fixup($file);
145	dpavlin	19	warn "## open( $file, $mode ) pending: ", $pending->{$file}->{open}, " mode $mode: ", dump( $mode_desc )," $path [", -s $path, "]\n" if $debug;
146	dpavlin	1	my $fh;
147	dpavlin	8
148			my $tmp = $mount->{tmp} . '/' . $file;
149			if ( -e $tmp ) {
150			$path = $tmp;
151			} elsif ( $path =~ m/\.gz$/ ) {
152			my $dest_path = $tmp;
153			$dest_path =~ s!/[^/]+$!!; #!vim-fix
154			mkpath $dest_path unless -e $dest_path;
155	dpavlin	23	if ( -s $path ) {
156			file_copy( '<:gzip', $path, '>', $tmp )
157			} else {
158			warn "ERROR: filesystem corruption, $path is zero size\n";
159			}
160	dpavlin	8	$path = $tmp;
161			}
162
163	dpavlin	21	if ( sysopen($fh , $path, $mode) ) {
164			close($fh) \|\| confess "can't close $path: $!";
165			warn "<<< open $path [", -e $path ? -s $path : 'new' , "]\n";
166			$pending->{$file}->{path} = $path;
167			return 0;
168			} else {
169	dpavlin	26	warn "ERROR: can't open $path -- $!";
170	dpavlin	21	return -$!;
171			}
172
173	dpavlin	1	}
174
175			sub x_read {
176			my ($file,$bufsize,$off) = @_;
177			my ($rv) = -ENOSYS();
178			my $path = fixup( $file );
179	dpavlin	10
180	dpavlin	12	confess "no pending file $file ", dump( $pending ) unless defined( $pending->{$file} );
181
182	dpavlin	1	return -ENOENT() unless -e $path;
183	dpavlin	10
184			my $fh = new IO::File;
185			return -ENOSYS() unless open($fh,$pending->{$file}->{path});
186
187	dpavlin	1	if(seek($fh,$off,SEEK_SET)) {
188			read($fh,$rv,$bufsize);
189			}
190	dpavlin	10
191	dpavlin	1	return $rv;
192			}
193
194			sub x_write {
195			my ($file,$buf,$off) = @_;
196	dpavlin	25
197	dpavlin	10	my $rv;
198	dpavlin	1	my $path = fixup($file);
199	dpavlin	10
200	dpavlin	12	confess "no pending file $file ", dump( $pending ) unless defined( $pending->{$file} );
201
202	dpavlin	1	return -ENOENT() unless -e $path;
203	dpavlin	10
204	dpavlin	26	$path = $pending->{$file}->{path} \|\| confess "no path for $file in ", dump( $pending );
205			confess "write into non-existant $path for $file: $!" unless -e $path;
206
207	dpavlin	10	my $fh = new IO::File;
208	dpavlin	26	return -ENOSYS() unless open($fh,'+<',$path);
209	dpavlin	1	if($rv = seek( $fh ,$off,SEEK_SET)) {
210			$rv = print( $fh $buf );
211	dpavlin	26	warn "## write $path offset $off [",length( $buf ), "]\n" if $debug;
212			$pending->{$file}->{write}++;
213	dpavlin	1	}
214			$rv = -ENOSYS() unless $rv;
215	dpavlin	26	close($fh) \|\| warn "can't close $path: $!";
216	dpavlin	1	return length($buf);
217			}
218
219			sub err { return (-shift \|\| -$!) }
220
221			sub x_readlink { return readlink(fixup(shift)); }
222	dpavlin	25	sub x_unlink {
223			my $file = shift;
224			my $path = fixup( $file );
225	dpavlin	1
226	dpavlin	25	if ( $file =~ m#\Q/.fuse_hidden\E# ) {
227			return unlink $path ? 0 : -$1;
228			}
229
230			warn "# unlink( $file )\n";
231
232			unlink $path \|\| return 0;
233
234			my $tmp = $mount->{tmp} . '/' . $file;
235			unlink $tmp if ( -e $tmp );
236
237			delete( $pending->{$file} );
238			return 0;
239			}
240
241	dpavlin	1	sub x_symlink { return symlink(shift,fixup(shift)) ? 0 : -$!; }
242
243			sub x_rename {
244	dpavlin	18	my ($old,$new) = @_;
245			my $old_path = fixup($old);
246			my $new_path = fixup($new);
247			$new_path .= '.gz' if ( $old_path =~ m/\.gz$/ && $new_path !~ m/\.gz$/ );
248
249			my $err = rename($old_path,$new_path) ? 0 : -ENOENT();
250			warn "## rename( $old_path => $new_path ) = $err\n";
251
252			my $tmp = $mount->{tmp} . '/' . $old;
253			if ( -e $tmp ) {
254	dpavlin	25	if ( $new =~ m#\Q/.fuse_hidden\E# ) {
255			unlink $tmp \|\| confess "can't unlink $tmp for $new\n";
256			} else {
257			my $new_tmp = $mount->{tmp} . '/' . $new;
258			rename $tmp, $new_tmp \|\| confess "can't rename $tmp -> $new_tmp : $!";
259			}
260	dpavlin	18	}
261
262	dpavlin	20	if (defined( $pending->{$old} )) {
263			$pending->{$new} = $pending->{$old};
264
265			my $path = $pending->{$old}->{path};
266			$path =~ s/\Q$old\E/$new/;
267			$pending->{$new}->{path} = $path;
268
269	dpavlin	25	delete( $pending->{$old} );
270			warn "## tweaking pending to ", dump( $pending ) if $debug;
271	dpavlin	20	}
272
273	dpavlin	1	return $err;
274			}
275			sub x_link { return link(fixup(shift),fixup(shift)) ? 0 : -$! }
276
277			sub x_chown {
278	dpavlin	26	my ($file,$uid,$gid) = @_;
279			my $path = fixup($file);
280	dpavlin	1	print "nonexistent $path\n" unless -e $path;
281			# perl's chown() does not chown symlinks, it chowns the symlink's
282			# target. it fails when the link's target doesn't exist, because
283			# the stat64() syscall fails.
284			# this causes error messages when unpacking symlinks in tarballs.
285			my ($err) = syscall(&SYS_lchown,$path,$uid,$gid,$path) ? -$! : 0;
286	dpavlin	26
287			my $tmp = $mount->{tmp} . '/' . $file;
288			syscall(&SYS_lchown,$file,$uid,$gid,$path) if -e $tmp;
289
290	dpavlin	1	return $err;
291			}
292
293			sub x_chmod {
294			my ($path) = fixup(shift);
295			my ($mode) = shift;
296			my ($err) = chmod($mode,$path) ? 0 : -$!;
297			return $err;
298			}
299
300	dpavlin	14	sub x_truncate {
301			my ( $file,$size ) = @_;
302			my $path = fixup($file);
303			my $rv = truncate( $path, $size ) ? 0 : -$! ;
304			if ( $path =~ m/\.gz$/ ) {
305			my $no_gz = $path;
306			$no_gz =~ s/\.gz$//;
307			rename $path, $no_gz \|\| confess "can't rename $path -> $no_gz: $!";
308			}
309	dpavlin	21	warn "## truncate( $file $size ) $path [", -s $path, "] = $rv\n" if $debug;
310	dpavlin	15	$pending->{$file}->{write}++;
311	dpavlin	14	return $rv;
312			}
313	dpavlin	1	sub x_utime { return utime($_[1],$_[2],fixup($_[0])) ? 0:-$!; }
314
315			sub x_mkdir { my ($name, $perm) = @_; return 0 if mkdir(fixup($name),$perm); return -$!; }
316			sub x_rmdir { return 0 if rmdir fixup(shift); return -$!; }
317
318			sub x_mknod {
319			# since this is called for ALL files, not just devices, I'll do some checks
320			# and possibly run the real mknod command.
321			my ($file, $modes, $dev) = @_;
322			$file = fixup($file);
323			$! = 0;
324			syscall(&SYS_mknod,$file,$modes,$dev);
325			return -$!;
326			}
327
328			sub x_release {
329			my ( $file, $mode ) = @_;
330	dpavlin	25
331			if ( $file =~ m#\Q/.fuse_hidden\E# ) {
332			warn "release internal $file\n" if $debug;
333			delete( $pending->{$file} );
334			return 0;
335			}
336
337	dpavlin	1	if ( ! defined( $pending->{$file} ) ) {
338			warn "release $file, NO PENDING DATA\n";
339			return 0;
340			} elsif ( ! defined( $pending->{$file}->{write} ) ) {
341			warn "release $file, not written into\n";
342			} elsif ( defined( $pending->{$file}->{open} ) && $pending->{$file}->{open} == 1 ) {
343	dpavlin	5	my $path = $pending->{$file}->{path} \|\| confess "no path for $file ? ", dump( $pending );
344			my $dest = fixup( $file );
345
346			# cleanup old compressed copy
347			if ( $dest =~ /\.gz$/ ) {
348			warn "## remove old $dest\n";
349	dpavlin	8	unlink $dest \|\| confess "can't remove $dest: $!";
350	dpavlin	5	$dest =~ s/\.gz$//;
351			}
352
353	dpavlin	1	if ( $file =~ $skip_extensions_regex ) {
354	dpavlin	20	warn "release $file [",-s $path,"] skipped compression\n";
355	dpavlin	5	file_copy( '<', $path, '>', $dest ) if ( $path ne $dest );
356			} elsif ( -s $path < $min_compress_size ) {
357	dpavlin	20	warn "release $file [",-s $path,"] uncompressed, too small\n";
358	dpavlin	5	file_copy( '<', $path, '>', $dest ) if ( $path ne $dest );
359	dpavlin	1	} else {
360	dpavlin	20	warn "release $file [",-s $path,"] compressing\n";
361	dpavlin	1
362	dpavlin	20	my $comp = $dest . '.gz';
363			file_copy( '<', $path, '>:gzip', $comp );
364	dpavlin	1
365	dpavlin	20	my ( $size_path, $size_comp ) = ( -s $path, -s $comp );
366	dpavlin	1
367	dpavlin	20	if ( $size_path <= $size_comp ) {
368			warn ">>> $size_path <= $size_comp leaving uncompressed\n";
369			unlink $comp \|\| warn "can't reamove: $comp: $!";
370			} else {
371			warn ">>> compressed $size_path -> $size_comp ",int(($size_comp * 100) / $size_path),"%\n";
372			# FIXME add timeout to remove uncompressed version?
373			unlink $path \|\| warn "can't remove $path: $!";
374			}
375	dpavlin	1	}
376			} else {
377			warn "release $file, but still used ", $pending->{$file}->{open} , " times, delaying compression\n";
378			}
379	dpavlin	13	$pending->{$file}->{open}--;
380			if ( $pending->{$file}->{open} == 0 ) {
381			warn "## cleanup pending $file [", -s fixup($file), "]\n" if $debug;
382			delete( $pending->{$file} );
383			}
384	dpavlin	1	return 0;
385			}
386
387			# kludge
388			sub x_statfs {return 255,1000000,500000,1000000,500000,4096}
389			Fuse::main(
390			mountpoint=>$mount->{to},
391			getattr =>"main::x_getattr",
392			readlink=>"main::x_readlink",
393			getdir =>"main::x_getdir",
394			mknod =>"main::x_mknod",
395			mkdir =>"main::x_mkdir",
396			unlink =>"main::x_unlink",
397			rmdir =>"main::x_rmdir",
398			symlink =>"main::x_symlink",
399			rename =>"main::x_rename",
400			link =>"main::x_link",
401			chmod =>"main::x_chmod",
402			chown =>"main::x_chown",
403			truncate=>"main::x_truncate",
404			utime =>"main::x_utime",
405			open =>"main::x_open",
406			read =>"main::x_read",
407			write =>"main::x_write",
408			statfs =>"main::x_statfs",
409			release =>"main::x_release",
410			# threaded=>1,
411	dpavlin	23	debug => $fuse_debug,
412	dpavlin	1	);