gearman/send_file.pl

   1 #!/usr/bin/perl
   2 use warnings;
   3 use strict;
   4
   5 use Data::Dump qw(dump);
   6 use File::Path qw(make_path);
   7
   8 sub home_dir {
   9         my $login = shift;
  10         my ( undef, undef, $uid, $gid, undef, undef, $email, $dir, $shell ) = getpwnam $login;
  11         return $dir;
  12 }
  13
  14 use Gearman::Worker;
  15 my $worker = Gearman::Worker->new;
  16 $worker->job_servers('127.0.0.1:4730');
  17
  18 $worker->register_function( send_file => sub {
  19         my ($job) = @_;
  20
  21         my $work = $job->arg;
  22         chomp $work;
  23         warn "# send_file [$work]\n";
  24
  25         my ( $from, $to ) = split(/#/,$work,2);
  26
  27         my $f_dir = home_dir($1) if $from =~ s/~(\w+)//;
  28         my $t_dir = home_dir($1) if $to   =~ s/~(\w+)//;
  29
  30         warn "send_file $f_dir $from -> $t_dir $to\n";
  31
  32         my $t_basedir = $t_dir . $to;
  33         $t_basedir =~ s{/[^/]+$}{};
  34         make_path $t_basedir unless -d $t_basedir;
  35         link $f_dir . $from => $t_dir . $to;
  36
  37         return "send_file $f_dir $from -> $t_dir $to";
  38 });
  39
  40
  41 $worker->register_function( delete => sub {
  42         my ($job) = @_;
  43         my $work = $job->arg;
  44         chomp $work;
  45         warn "# delete [$work]\n";
  46
  47         my $dir = home_dir($1) if $work =~ s/~(\w+)//;
  48         my $full = $dir . $work;
  49
  50         if ( -d $full ) {
  51                 warn "rmdir $full\n";
  52                 rmdir $full || warn "ERROR $!";
  53         } else {
  54                 warn "unlink $full\n";
  55                 unlink $full || warn "ERROR $!";
  56         }
  57
  58 });
  59
  60 warn "$0 pid $$ waitng for jobs\n";
  61 $worker->work while 1;
  62