view release on metacpan or  search on metacpan

lib/HTTP/Server/Connection.pm  view on Meta::CPAN

my %filetype =
  ( &S_IFSOCK => 's', &S_IFLNK => 'l', &S_IFREG => '-', &S_IFBLK => 'b'
  , &S_IFDIR  => 'd', &S_IFCHR => 'c', &S_IFIFO => 'p');

my @flags    = ('---', '--x', '-w-', '-wx', 'r--', 'r-x', 'rw-', 'rwx');
    
sub directoryList($$$@)
{   my ($self, $req, $dirname, $callback, %opts) = @_;

    trace $self->id. " listing of directory $dirname";
    opendir my $from_dir, $dirname
        or return $self->sendStatus($req, RC_FORBIDDEN);

    my $names      = $opts{names} || qr/^[^.]/;
    my $prefilter
       = ref $names eq 'Regexp' ? sub { $_[0] =~ $names }
       : ref $names eq 'CODE'   ? $names
       : panic "directoryList(names) must be regexp or code, not $names";

    my $postfilter = $opts{filter} || sub {1};
    ref $postfilter eq 'CODE'
        or panic "directoryList(filter) must be code, not $postfilter";

    my $hide_symlinks = $opts{hide_symlinks};

    my $run_async = sub
      { my (%dirlist, %users, %groups);
        foreach my $name (grep {$prefilter->($_)} readdir $from_dir)
        {   my $path = $dirname.$name;
            my %d = (name => $name, path => $path);
            @d{@stat_fields}
                = $hide_symlinks ? stat($path) : lstat($path);

               if(!$hide_symlinks && -l _)
                        { @d{qw/kind is_symlink  /} = ('SYMLINK',  1)}
            elsif(-d _) { @d{qw/kind is_directory/} = ('DIRECTORY',1)}
            elsif(-f _) { @d{qw/kind is_file     /} = ('FILE',     1)}
            else        { @d{qw/kind is_other    /} = ('OTHER',    1)}

            $postfilter->(\%d)
                or next;

            if($d{is_symlink})
            {   my $sl = $d{symlink_dest} = readlink $path;
                $d{symlink_dest_exists} = -e $sl;
            }
            elsif($d{is_file})
            {   my ($s, $l) = ($d{size}, '  ');
                ($s,$l) = ($s/1024, 'kB') if $s > 1024;
                ($s,$l) = ($s/1024, 'MB') if $s > 1024;
                ($s,$l) = ($s/1024, 'GB') if $s > 1024;
                $d{size_nice} = sprintf +($s>=100?"%.0f%s":"%.1f%s"), $s,$l;
            }
            elsif($d{is_directory})
            {   $d{name} .= '/';
            }

            if($d{is_file} || $d{is_directory})
            {   $d{user}  = $users{$d{uid}} ||= getpwuid $d{uid};
                $d{group} = $users{$d{gid}} ||= getgrgid $d{gid};
                my $mode = $d{mode};
                my $b = $filetype{$mode & S_IFMT} || '?';
                $b   .= $flags[ ($mode & S_IRWXU) >> 6 ];
                substr($b, -1, -1) = 's' if $mode & S_ISUID;
                $b   .= $flags[ ($mode & S_IRWXG) >> 3 ];
                substr($b, -1, -1) = 's' if $mode & S_ISGID;
                $b   .= $flags[  $mode & S_IRWXO ];
                substr($b, -1, -1) = 't' if $mode & S_ISVTX;
                $d{flags}      = $b;
                $d{mtime_nice} = strftime "%F %T", localtime $d{mtime};
            }
            $dirlist{$name} = \%d;
        }
        \%dirlist;
      };

    $self->async($req, $run_async, $callback);
    undef;
}


sub async
{   my ($self, $req, $run, $after) = @_;

    my ($reader, $writer);
    unless(pipe $reader, $writer)
    {   $self->sendStatus($req, RC_INTERNAL_SERVER_ERROR, "pipe: $!");
        return 0;
    }
 
    my $pid = fork;
    unless(defined $pid)
    {   trace "failed to fork: $!";
        $self->sendStatus($req, RC_INTERNAL_SERVER_ERROR, "fork: $!");
        return 0;
    }

    if($pid==0)  # child
    {   close $reader;
        my %data;
        $data{user} = [ $run->() ];
        $writer->print(freeze \%data);
        exit 0;
    }

    # parent
    close $writer;
 
    my $mux = $self->{HSC_mux};
    $mux->add($reader);
    my $callback = sub
      { my $data = eval { thaw ${$_[0]} };
        $mux->remove($reader);
        waitpid $pid, 0;   # need to check return
        $after->(@{$data->{user}});
        $self->handleRequests;
      };

    $mux->set_callback_object(_PUMP::READFILE->new($callback), $reader);