/[fuse-comp]/fuse-comp.pl
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /fuse-comp.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 20 by dpavlin, Mon Jul 9 16:20:07 2007 UTC revision 28 by dpavlin, Tue Jul 10 01:10:49 2007 UTC
# Line 12  use File::Path; Line 12  use File::Path;
12  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
13  use Carp qw/confess/;  use Carp qw/confess/;
14  use IO::File;  use IO::File;
15    use Getopt::Long;
16    
17    my $debug = 0;
18    my $fuse_debug = 0;
19    
20    GetOptions(
21            'debug+' => \$debug,
22            'fuse-debug+' => \$fuse_debug,
23    );
24    
25  my $mount = {  my $mount = {
26          from    => '/tmp/comp',          from    => '/tmp/comp',
# Line 19  my $mount = { Line 28  my $mount = {
28          tmp             => '/dev/shm/comp',          tmp             => '/dev/shm/comp',
29  };  };
30    
 my $debug = shift @ARGV;  
   
31  my $skip_extensions_regex = qr/\.(?:sw[a-z]|gif|png|jpeg|jpg|avi|rar|zip|bz2|gz|tgz|avi|mpeg|mpg|tmp|temp)$/i;  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    
33  # don't compress files smaller than this  # don't compress files smaller than this
# Line 35  foreach my $dir ( keys %$mount ) { Line 42  foreach my $dir ( keys %$mount ) {
42    
43  my $pending;  my $pending;
44    
45    sub real_name {
46            my ( $dir, $name ) = @_;
47            if ( -e "$dir/${name}.gz" ) {
48                    confess "ASSERT: unexpected $dir/$name exists" if -e "$dir/$name";
49                    return "${name}.gz";
50            }
51            return $name;
52    }
53    
54  sub fixup {  sub fixup {
55          my ( $path ) = @_;          my ( $path ) = @_;
56          my $full = $mount->{from} . '/' . $path;          return $mount->{from} . '/' . real_name( $mount->{from}, $path );
         if ( -e $full . '.gz' ) {  
                 return $full . '.gz';  
         }  
         return $full;  
57  }  }
58    
59  sub original_name {  sub original_name {
# Line 69  sub gzip_original_size { Line 81  sub gzip_original_size {
81          return unpack("L", $buff);          return unpack("L", $buff);
82  }  }
83    
 sub unlink_all {  
         my $file = shift;  
         warn "# unlink_all( $file )\n";  
   
         my $path = fixup( $file );  
         unlink $path || return 0;  
   
         my $tmp = $mount->{tmp} . '/' . $file;  
         unlink $tmp if ( -e $tmp );  
   
         delete( $pending->{$file} );  
         return 1;  
 }  
   
84  sub x_getattr {  sub x_getattr {
85          my ($file) = fixup(shift);          my ($file) = fixup(shift);
86          my (@list) = lstat($file);          my (@list) = lstat($file);
# Line 124  sub file_copy { Line 122  sub file_copy {
122          undef $s;          undef $s;
123  }  }
124    
125    sub create_tmp_file {
126            my $file = shift;
127    
128            my $path = fixup( $file );
129            my $tmp = $mount->{tmp} . '/' . $file;
130            if ( -e $tmp ) {
131                    $path = $tmp;
132            } elsif ( $path =~ m/\.gz$/ ) {
133                    my $dest_path = $tmp;
134                    $dest_path =~ s!/[^/]+$!!;      #!vim-fix
135                    mkpath $dest_path unless -e $dest_path;
136                    if ( -s $path ) {
137                            file_copy( '<:gzip', $path, '>', $tmp )
138                    } else {
139                            warn "ERROR: filesystem corruption, $path is zero size\n";
140                    }
141                    $path = $tmp;
142            }
143            warn "## create_temp_file( $file ) => $path [", -s $path, "]\n";
144            return $path;
145    }
146    
147    sub compress_path_dest {
148            my ( $path, $dest ) = @_;
149    
150            # cleanup old compressed copy
151            if ( $dest =~ /\.gz$/ ) {
152                    warn "## remove old $dest\n";
153                    unlink $dest || confess "can't remove $dest: $!";
154                    $dest =~ s/\.gz$//;
155            }
156    
157            if ( $path =~ $skip_extensions_regex ) {
158                    warn "$path [",-s $path,"] skipped compression\n";
159                    file_copy( '<', $path, '>', $dest ) if ( $path ne $dest );
160            } elsif ( -s $path < $min_compress_size ) {
161                    warn "$path [",-s $path,"] uncompressed, too small\n";
162                    file_copy( '<', $path, '>', $dest ) if ( $path ne $dest );
163            } else {
164                    warn "$path [",-s $path,"] compressing\n";
165    
166                    my $comp = $dest . '.gz';
167                    file_copy( '<', $path, '>:gzip', $comp );
168    
169                    my ( $size_path, $size_comp ) = ( -s $path, -s $comp );
170    
171                    if ( $size_path <= $size_comp ) {
172                            warn ">>> $size_path <= $size_comp leaving uncompressed\n";
173                            unlink $comp || confess "can't remove: $comp: $!";
174                    } else {
175                            warn ">>> compressed $size_path -> $size_comp ",int(($size_comp * 100) / $size_path),"%\n";
176                            # FIXME add timeout to remove uncompressed version?
177                            unlink $path || confess "can't remove $path: $!";
178                    }
179            }
180    }
181    
182  sub x_open {  sub x_open {
183          my ($file) = shift;          my ($file) = shift;
184          my ($mode) = shift;          my ($mode) = shift;
# Line 148  sub x_open { Line 203  sub x_open {
203                  create => $mode && O_CREAT,                  create => $mode && O_CREAT,
204                  trunc => $mode && O_TRUNC,                  trunc => $mode && O_TRUNC,
205          };          };
206          my $path = fixup($file);  
207            my $path = create_tmp_file( $file );
208    
209          warn "## open( $file, $mode ) pending: ", $pending->{$file}->{open}, " mode $mode: ", dump( $mode_desc )," $path [", -s $path, "]\n" if $debug;          warn "## open( $file, $mode ) pending: ", $pending->{$file}->{open}, " mode $mode: ", dump( $mode_desc )," $path [", -s $path, "]\n" if $debug;
210    
211          my $fh;          my $fh;
212    
213          my $tmp = $mount->{tmp} . '/' . $file;          if ( sysopen($fh , $path, $mode) ) {
214          if ( -e $tmp ) {                  close($fh) || confess "can't close $path: $!";
215                  $path = $tmp;                  warn "<<< open $path [", -e $path ? -s $path : 'new' , "]\n";
216          } elsif ( $path =~ m/\.gz$/ ) {                  $pending->{$file}->{path} = $path;
217                  my $dest_path = $tmp;                  return 0;
218                  $dest_path =~ s!/[^/]+$!!;      #!vim-fix          } else {
219                  mkpath $dest_path unless -e $dest_path;                  warn "ERROR: can't open $path -- $!";
220                  file_copy( '<:gzip', $path, '>', $tmp );                  return -$!;
                 $path = $tmp;  
221          }          }
         warn "<<< open abs path: $path [", -e $path ? -s $path : 'new' , "]\n";  
         return -$! unless sysopen($fh , $path, $mode);  
         close($fh);  
222    
         $pending->{$file}->{path} = $path;  
         return 0;  
223  }  }
224    
225  sub x_read {  sub x_read {
# Line 191  sub x_read { Line 243  sub x_read {
243    
244  sub x_write {  sub x_write {
245          my ($file,$buf,$off) = @_;          my ($file,$buf,$off) = @_;
246          $pending->{$file}->{write}++;  
247          my $rv;          my $rv;
248          my $path = fixup($file);          my $path = fixup($file);
249    
# Line 199  sub x_write { Line 251  sub x_write {
251    
252          return -ENOENT() unless -e $path;          return -ENOENT() unless -e $path;
253    
254            $path = $pending->{$file}->{path} || confess "no path for $file in ", dump( $pending );
255            confess "write into non-existant $path for $file: $!" unless -e $path;
256    
257          my $fh = new IO::File;          my $fh = new IO::File;
258          return -ENOSYS() unless open($fh,'+<',$pending->{$file}->{path});          return -ENOSYS() unless open($fh,'+<',$path);
259          if($rv = seek( $fh ,$off,SEEK_SET)) {          if($rv = seek( $fh ,$off,SEEK_SET)) {
260                  $rv = print( $fh $buf );                  $rv = print( $fh $buf );
261                  warn "## write ", $pending->{$file}->{path}, " $off ",length( $buf ), "\n" if $debug;                  warn "## write $path offset $off [",length( $buf ), "]\n" if $debug;
262                    $pending->{$file}->{write}++;
263          }          }
264          $rv = -ENOSYS() unless $rv;          $rv = -ENOSYS() unless $rv;
265          close($fh);          close($fh) || warn "can't close $path: $!";
266          return length($buf);          return length($buf);
267  }  }
268    
269  sub err { return (-shift || -$!) }  sub err { return (-shift || -$!) }
270    
271  sub x_readlink { return readlink(fixup(shift));         }  sub x_readlink { return readlink(fixup(shift)); }
272  sub x_unlink   { return unlink_all( shift ) ? 0 : -$! }  
273    sub x_unlink   {
274            my $file = shift;
275            my $path = fixup( $file );
276    
277            if ( $file =~ m#\Q/.fuse_hidden\E# ) {
278                    return unlink $path ? 0 : -$1;
279            }
280    
281            warn "# unlink( $file )\n";
282    
283            unlink $path || return 0;
284    
285            my $tmp = $mount->{tmp} . '/' . $file;
286            unlink $tmp if ( -e $tmp );
287    
288            delete( $pending->{$file} );
289            return 0;
290    }
291    
292    sub x_symlink {
293            my ($from,$to) = @_;
294    
295            my $from_path = $from;  #fixup( $from );
296            my $to_path = fixup( $to );
297    
298            my $rv = symlink( $from_path, $to_path ) ? 0 : -$!;
299            warn "# symlink( $from_path -> $to_path ) = $rv\n" if $debug;
300    
301            my $tmp = $mount->{tmp} . '/' . $from;
302            if ( -e $tmp ) {
303                    my $tmp_to = $mount->{$tmp} . '/' . $to;
304                    symlink( $tmp, $tmp_to ) || confess "can't symlink $tmp -> $tmp_to: $!";
305            }
306            return $rv;
307    }
308    
309    sub x_link {
310            my ($from,$to) = @_;
311    
312            my $from_path = fixup($from);
313            my $to_path = fixup($to);
314            $to_path .= '.gz' if ( $from_path =~ m/\.gz$/ && $to_path !~ m/\.gz$/ );
315    
316            my $rv = link( $from_path, $to_path ) ? 0 : -$!;
317    
318            warn "# link( $from_path -> $to_path ) = $rv\n" if $debug;
319    
320  sub x_symlink { return symlink(shift,fixup(shift)) ? 0 : -$!; }          return $rv;
321    }
322    
323  sub x_rename {  sub x_rename {
324          my ($old,$new) = @_;          my ($old,$new) = @_;
# Line 228  sub x_rename { Line 331  sub x_rename {
331    
332          my $tmp = $mount->{tmp} . '/' . $old;          my $tmp = $mount->{tmp} . '/' . $old;
333          if ( -e $tmp ) {          if ( -e $tmp ) {
334                  my $new_tmp = $mount->{tmp} . '/' . $new;                  if ( $new =~ m#\Q/.fuse_hidden\E# ) {
335                  rename $tmp, $new_tmp || confess "can't rename $tmp -> $new_tmp : $!";                          unlink $tmp || confess "can't unlink $tmp for $new\n";
336                    } else {
337                            my $new_tmp = $mount->{tmp} . '/' . $new;
338                            rename $tmp, $new_tmp || confess "can't rename $tmp -> $new_tmp : $!";
339                    }
340          }          }
341    
342          if (defined( $pending->{$old} )) {          if (defined( $pending->{$old} )) {
# Line 240  sub x_rename { Line 347  sub x_rename {
347                  $pending->{$new}->{path} = $path;                  $pending->{$new}->{path} = $path;
348    
349                  delete( $pending->{$old} );                  delete( $pending->{$old} );
350                    warn "## tweaking pending to ", dump( $pending ) if $debug;
351          }          }
352    
353          return $err;          return $err;
354  }  }
 sub x_link { return link(fixup(shift),fixup(shift)) ? 0 : -$! }  
355    
356  sub x_chown {  sub x_chown {
357          my ($path) = fixup(shift);          my ($file,$uid,$gid) = @_;
358            my $path = fixup($file);
359          print "nonexistent $path\n" unless -e $path;          print "nonexistent $path\n" unless -e $path;
         my ($uid,$gid) = @_;  
360          # perl's chown() does not chown symlinks, it chowns the symlink's          # perl's chown() does not chown symlinks, it chowns the symlink's
361          # target.  it fails when the link's target doesn't exist, because          # target.  it fails when the link's target doesn't exist, because
362          # the stat64() syscall fails.          # the stat64() syscall fails.
363          # this causes error messages when unpacking symlinks in tarballs.          # this causes error messages when unpacking symlinks in tarballs.
364          my ($err) = syscall(&SYS_lchown,$path,$uid,$gid,$path) ? -$! : 0;          my ($err) = syscall(&SYS_lchown,$path,$uid,$gid,$path) ? -$! : 0;
365    
366            my $tmp = $mount->{tmp} . '/' . $file;
367            syscall(&SYS_lchown,$file,$uid,$gid,$path) if -e $tmp;
368    
369          return $err;          return $err;
370  }  }
371    
# Line 267  sub x_chmod { Line 378  sub x_chmod {
378    
379  sub x_truncate {  sub x_truncate {
380          my ( $file,$size ) = @_;          my ( $file,$size ) = @_;
381          my $path = fixup($file);  
382          my $rv = truncate( $path, $size ) ? 0 : -$! ;          #confess "no pending file $file to truncate in ", dump( $pending ) unless defined( $pending->{$file} );
383          if ( $path =~ m/\.gz$/ ) {  
384                  my $no_gz = $path;          my $path;
385                  $no_gz =~ s/\.gz$//;  
386                  rename $path, $no_gz || confess "can't rename $path -> $no_gz: $!";          if (defined( $pending->{$file} )) {
387                    $pending->{$file}->{write}++;
388                    $path = fixup( $file );
389            } else {
390                    $path = create_tmp_file( $file );
391                    compress_path_dest( $path, fixup( $file ) );
392          }          }
393          warn "## truncate( $file $size ) $path [", -s $path, "]\n";          my $rv = truncate( $path, $size ) ? 0 : -$! ;
394          $pending->{$file}->{write}++;          warn "## truncate( $file $size ) $path [", -s $path, "] = $rv\n" if $debug;
395    
396          return $rv;          return $rv;
397  }  }
398    
399  sub x_utime { return utime($_[1],$_[2],fixup($_[0])) ? 0:-$!; }  sub x_utime { return utime($_[1],$_[2],fixup($_[0])) ? 0:-$!; }
400    
401  sub x_mkdir { my ($name, $perm) = @_; return 0 if mkdir(fixup($name),$perm); return -$!; }  sub x_mkdir { my ($name, $perm) = @_; return 0 if mkdir(fixup($name),$perm); return -$!; }
# Line 295  sub x_mknod { Line 413  sub x_mknod {
413    
414  sub x_release {  sub x_release {
415          my ( $file, $mode ) = @_;          my ( $file, $mode ) = @_;
416    
417            if ( $file =~ m#\Q/.fuse_hidden\E# ) {
418                    warn "release internal $file\n" if $debug;
419                    delete( $pending->{$file} );
420                    return 0;
421            }
422    
423          if ( ! defined( $pending->{$file} ) ) {          if ( ! defined( $pending->{$file} ) ) {
424                  warn "release $file, NO PENDING DATA\n";                  warn "release $file, NO PENDING DATA\n";
425                  return 0;                  return 0;
# Line 303  sub x_release { Line 428  sub x_release {
428          } elsif ( defined( $pending->{$file}->{open} ) && $pending->{$file}->{open} == 1 ) {          } elsif ( defined( $pending->{$file}->{open} ) && $pending->{$file}->{open} == 1 ) {
429                  my $path = $pending->{$file}->{path} || confess "no path for $file ? ", dump( $pending );                  my $path = $pending->{$file}->{path} || confess "no path for $file ? ", dump( $pending );
430                  my $dest = fixup( $file );                  my $dest = fixup( $file );
431                    compress_path_dest( $path, $dest );
432    
                 # 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: $!";  
                         }  
                 }  
433          } else {          } else {
434                  warn "release $file, but still used ", $pending->{$file}->{open} , " times, delaying compression\n";                  warn "release $file, but still used ", $pending->{$file}->{open} , " times, delaying compression\n";
435          }          }
# Line 369  Fuse::main( Line 465  Fuse::main(
465          statfs  =>"main::x_statfs",          statfs  =>"main::x_statfs",
466          release =>"main::x_release",          release =>"main::x_release",
467  #       threaded=>1,  #       threaded=>1,
468  #       debug   => 1,          debug   => $fuse_debug,
469  );  );

Legend:
Removed from v.20  
changed lines
  Added in v.28

  ViewVC Help
Powered by ViewVC 1.1.26