186 lines
4.1 KiB
Perl
186 lines
4.1 KiB
Perl
package Simba::DA;
|
|
use strict;
|
|
use warnings;
|
|
|
|
use Encode;
|
|
use File::Find;
|
|
use File::stat;
|
|
|
|
sub new {
|
|
my ($class) = @_;
|
|
my $self = {};
|
|
bless $self, $class;
|
|
|
|
# read local config file here.
|
|
# such a config file could contain:
|
|
#
|
|
# * some means for the CA to identify itself
|
|
# (currently we use SSH for that)
|
|
#
|
|
# * A list of directories which should not be descended into
|
|
# (for example, /proc, /sys, networked filesystems and
|
|
# filesystems on removable media, ...)
|
|
#
|
|
# * encoding rules (e.g., charset of filenames)
|
|
#
|
|
# * Other system dependent parameters, e.g., whether to use ACLs
|
|
#
|
|
# For now we just hardcode the stuff:
|
|
$self->{prune} = {
|
|
'/proc' => 1,
|
|
'/sys' => 1,
|
|
'/nfs' => 1,
|
|
'/tmp/hyre_be_dragones' => 1,
|
|
};
|
|
$self->{charset} = 'utf-8';
|
|
|
|
return $self;
|
|
|
|
}
|
|
|
|
my %dispatch = (
|
|
list => \&list,
|
|
default => \&no_such_command,
|
|
);
|
|
|
|
# the main loop:
|
|
# read one-line commands from stdin and dispatch commands
|
|
sub run {
|
|
my ($self) = @_;
|
|
|
|
binmode STDIN, ":raw";
|
|
binmode STDOUT, ":raw";
|
|
|
|
while (<>) {
|
|
chomp;
|
|
my @cmd = split();
|
|
my $sub = $dispatch{$cmd[0]} || $dispatch{default};
|
|
$self->$sub(@cmd);
|
|
}
|
|
}
|
|
|
|
sub list {
|
|
my ($self, $cmd, $path) = @_;
|
|
|
|
find({
|
|
preprocess
|
|
=> sub {
|
|
if ($self->{prune}{$File::Find::dir}) {
|
|
return ();
|
|
} else {
|
|
# not sure if sorting is useful
|
|
return sort @_;
|
|
}
|
|
},
|
|
wanted
|
|
=> sub {
|
|
my $st = lstat($_);
|
|
return unless $st; # ignore unstattable files.
|
|
|
|
my $fn = decode($self->{charset},
|
|
$File::Find::name);
|
|
$fn = quote($fn);
|
|
print $fn;
|
|
|
|
print "\n";
|
|
},
|
|
no_chdir => 1,
|
|
},
|
|
$path
|
|
);
|
|
|
|
}
|
|
|
|
sub permstr {
|
|
my ($perm) = @_;
|
|
|
|
return ($perm & 04 ? 'r' : '-') .
|
|
($perm & 02 ? 'w' : '-') .
|
|
($perm & 01 ? 'x' : '-');
|
|
}
|
|
|
|
my %ucache;
|
|
sub uid2name {
|
|
my ($uid) = @_;
|
|
return $ucache{$uid} if ($ucache{$uid});
|
|
my $uname = getpwuid($uid);
|
|
if ($uname) {
|
|
$ucache{$uid} = $uname;
|
|
} else {
|
|
# no user name - use numeric id
|
|
$ucache{$uid} = $uid;
|
|
}
|
|
}
|
|
|
|
|
|
my %gcache;
|
|
sub gid2name {
|
|
my ($gid) = @_;
|
|
return $gcache{$gid} if ($gcache{$gid});
|
|
my $gname = getgrgid($gid);
|
|
if ($gname) {
|
|
$gcache{$gid} = $gname;
|
|
} else {
|
|
# no group name - use numeric id
|
|
$gcache{$gid} = $gid;
|
|
}
|
|
}
|
|
|
|
sub quote {
|
|
my ($s) = @_;
|
|
$s =~ s{[\000-\040&=]}{sprintf("&#%d;", ord($&))}eg;
|
|
return encode('utf-8', $s);
|
|
}
|
|
|
|
my @typestr = (
|
|
#0 1 2 3 4 5 6 7
|
|
'?', 'p', 'c', '?', 'd', '?', 'b', '?',
|
|
'f', '?', 'l', '?', 's', '?', '?', '?',
|
|
);
|
|
sub typestr {
|
|
my ($mode) = @_;
|
|
$mode >>= 12;
|
|
return $typestr[$mode] || '?';
|
|
}
|
|
|
|
sub get {
|
|
my ($self, $cmd, $path) = @_;
|
|
|
|
}
|
|
|
|
sub metastr {
|
|
my ($fn, $st) = @_;
|
|
$st = lstat($fn) unless defined($st);
|
|
|
|
my $s = "";
|
|
|
|
my $mode = $st->mode;
|
|
my $uid = $st->uid;
|
|
my $gid = $st->gid;
|
|
my $rdev = $st->rdev;
|
|
my $size = $st->size;
|
|
my $mtime = $st->mtime;
|
|
|
|
# ignoring nlinks for now. We should store hard links somewhere
|
|
# however.
|
|
|
|
$s .= " " . 'id=' . $st->dev . ":" . $st->ino;
|
|
$s .= " " . 't=' . typestr($mode);
|
|
$s .= " " . 's=' . $size;
|
|
$s .= " " . 'm=' . $mtime;
|
|
$s .= " " . 'o=' . quote(uid2name($uid));
|
|
$s .= " " . 'g=' . quote(gid2name($gid));
|
|
my $acl = 'u::' . permstr(($mode & 0700) >> 6) . ',';
|
|
$acl .= 'g::' . permstr(($mode & 0070) >> 3) . ',';
|
|
$acl .= 'o:' . permstr(($mode & 0007) >> 0);
|
|
$s .= " " . 'acl=' . quote($acl);
|
|
$s .= " " . 'setuid=1' if $mode & 04000;
|
|
$s .= " " . 'setgid=1' if $mode & 02000;
|
|
$s .= " " . 'sticky=1' if $mode & 01000;
|
|
$s .= " " . 'rdev=' . $st->rdev if ($mode & 0120000) == 0020000;
|
|
}
|
|
|
|
1;
|
|
|
|
# vim: sw=4 expandtab
|