chown results from the CPAN

chown

OpenIndex

view release on metacpan or search on metacpan

    unless($args->{all}) {
	$uri.='?all=1';
	$c='&amp;';
    }
    if($args->{frame}) {
	$uri.="${c}frame=$args->{frame}";
	$c='&amp;';
    }
    $uri.="${c}dst=$args->{dst}" if $args->{dst};
    print STDERR "SelectAll() uri=$uri\n" if $debug;
    $r->header_out(Location=>$uri);
    REDIRECT;
}

sub Help {
 my ($r,$args,$cfg) = @_;
 my $uri=$cfg->{help}||DEFAULT_HELP_URL;
    $uri.="?version=$Apache::OpenIndex::VERSION&amp;postmax=$cfg->{postmax}";
    $uri.="&amp;mark=1"  if $cfg->{mark};
    $uri.="&amp;perms=1" if $args->{gid};
    $uri.="&amp;admin=1" if $args->{isadmin};
    $uri.="&amp;frame=$args->{frame}" if $args->{frame};
    $r->header_out(Location=>$uri);
    $r->log->notice(__PACKAGE__." $args->{user}: Help: $uri");
    REDIRECT;
}

sub Debug {
 my ($r,$args,$cfg) = @_;
 my $lang = new Apache::Language($r) if $cfg->{language};
 my $msg='';
 my $cmdname=$lang->{Debug} || 'Debug';
    $dodump = !$dodump if $debug;
    print STDERR "Debug=$dodump\n" if $debug;
    $r->log->notice(__PACKAGE__." $args->{user}: Debug: $dodump");
    1;
}

sub SetGID {	# Set the item (file or dir) GID 
 my ($r,$args,$cfg,$root,$src,$igid) = @_;
 my $lang = new Apache::Language($r) if $cfg->{language};
 my $msg='';
 my $cmdname=$lang->{SetGID} || 'SetGID';
 my $name;
    $src="$root$src";
    chomp $cmdname;
    if($igid=~m:[^0-9]:o) {		# if not a number look-up the group
	$name=$igid;
	unless(($igid=getgrnam $name)) {
	    $msg=$lang->{GIDbad} || 'GID name not found';
	    errmsg(qq~${cmdname}: "$name" $msg~);
	    return 0;
	}
    } else {
	unless(($name=getgrgid $igid)) {
	    $msg=$lang->{GIDbad} || 'GID name not found';
	    errmsg(qq~${cmdname}: "$igid" $msg~);
	    return 0;
	}
    }
    unless($igid && chown(-1,$igid,$src)) {
	$msg=$lang->{GIDset} || 'GID not set';
	errmsg(qq~${cmdname}: "$name" $msg~);
	return 0;
    }
    $r->log->notice(__PACKAGE__." $args->{user}: SetGID: $igid $src");
    1;
}

sub Revoke {
 my ($r,$args,$cfg) = @_;
 my $lang = new Apache::Language($r) if $cfg->{language};
 my $msg='';
 my $cmdname=$lang->{Revoke} || 'Revoke';
 my $uri = $r->uri;
 my $textlen=$cfg->{textlen} || DEFAULT_TEXT_LEN;
 my $halflen=($textlen+($textlen%2))/2;
    chomp $cmdname;
    $r->no_cache(1);	# Always make sure that the data is not cached
    return SKIP_INDEX unless httphead($r,"OpenIndex $cmdname");
    header($r,$args,$cfg) unless $args->{frame}; 
    tagout('h3',$cfg,'',"OpenIndex $cmdname</h3>");
 my $gotdata;
 my $type;
 my $name;
    foreach (keys %$users) {
	if($users->{$_} eq '-') {
	 my($ruser,$rgid)=m:^(.*?)#(.*?)#:;
	    unless($gotdata) {
		$msg=$lang->{Revoked} || 'The following have been revoked:';
		tagout('p',$cfg,'',"$msg</p>");
		tagout('table',$cfg,qq~summary="$msg" cols="2"~);
		tagout('tr',$cfg);
		tagout('th',$cfg,'',' Type </th>');
		tagout('th',$cfg,'',' Name </th></tr>');
		$gotdata=1;
	    }
	    if($ruser) {
		$type='user';
		$name=$ruser;
	    }
	    if($rgid) {
		$type='gid';
		$name=getgrgid $rgid || $rgid;
	    }
	    tagout('tr',$cfg);
	    tagout('td',$cfg,''," $type </td>");
	    tagout('td',$cfg,''," $name </td></tr>");
	}
    }
    print "</table>\n" if $gotdata;
    unless($gotdata) {
	$msg=$lang->{NoUsers} || 'No user or group revoke information available';
	tagout('p',$cfg,'',"$msg</p>");
    }
    tagout('form',$cfg,qq~method="post" action="$uri" enctype="multipart/form-data"~);
    etagout('input',$cfg,qq~type="text" name="id" size=$halflen maxlength=255~);
	$msg=$lang->{EnableUID} || 'Enable User';
	chomp $msg;
    etagout('input',$cfg,qq~type="submit" name="enauid" value="$msg"~);
	$msg=$lang->{DisableUID} || 'Disable User';

OpenIndex.pm view on Meta::CPAN

    etagout('input',$cfg,qq~type="reset" name="undo" value="$msg"~);;
	$msg=$lang->{Quit} || 'Quit';
	chomp $msg;
    etagout('input',$cfg,qq~type="submiT" name="quit" value="$msg"~);
	$msg=$lang->{Save} || 'Save';
	chomp $msg;
    etagout('input',$cfg,qq~type="submIt" name="save" value="$msg"~);
    tagout('p',$cfg);
    tagout('textarea',$cfg,qq~name="text" rows="24" cols="80"~);
    if($opened) {
	while(<ITEM>) {
	    chomp;
	    print(escape_html($_));
	}
	close ITEM;
    }
    ($inifile=$relsrc)=~s:^(.*/)(.+):$1\.$2\.ini:;
    print '</textarea></p>';
    tagout('p',$cfg);
    print qq~<input type="hidden" name="proc" value="Edit" />\n~,
	qq~<input type="hidden" name="edit" value="$relsrc" />\n~,
	qq~<input type="hidden" name="saver" value="$info{user}" />\n~,
	qq~<input type="hidden" name="info" value="$inifile" />\n~;
    hidenargs($args);
    print qq~</p></form>\n~;
    if($debug && $dodump) {
	use Data::Dumper;
	print "<hr /><pre>\%info\n";
	print Dumper \%info;
	print '</pre>';
	etagout('hr',$cfg);
    }
    $r->log->notice(__PACKAGE__." $args->{user}: Edit: $src");
    SKIP_INDEX;
}

sub MkDir {
 my ($r,$args,$cfg,$root,$src,$dst) = @_;
 my $lang = new Apache::Language($r) if $cfg->{language};
 my $msg;
 my $cmdname=$lang->{MkDir} || 'MkDir';
    chomp $cmdname;
    unless($dst) {
	$msg=$lang->{DestPath} || 'Bad destination path';
	errmsg("${cmdname}: $msg");
	return 0;
    }
    $dst="$root$dst";
    if(-e $dst) {
	$msg=$lang->{DestExists} || 'Destination exists';
	errmsg("${cmdname}: $msg");
	return 0;
    }
    if($args->{gid}) {
	my $fgid=parentok($dst,$args,$cfg,$cmdname,$lang);
	return 0 unless $fgid; 
	unless(mkdir $dst,0755) {
	    errmsg("${cmdname}: $!");
	    return 0;
	}
	chown(-1,$fgid,$dst);
    } else {
	unless(mkdir $dst,0755) {
	    errmsg("${cmdname}: $!");
	    return 0;
	}
    }
    $r->log->notice(__PACKAGE__." $args->{user}: MkDir: $dst");
    1;
}

sub Unzip {
 my ($r,$args,$cfg,$root,$src,$dst) = @_;
    $dst=~s:/$::;		# strip any trailing '/'
    use Archive::Zip qw( :ERROR_CODES :CONSTANTS );
    use Archive::Zip::Tree;
 my $lang = new Apache::Language($r) if $cfg->{language};
 my $msg;
 my $cmdname=$lang->{Unzip} || 'Unzip';
    chomp $cmdname;
    unless($dst) {
	$msg=$lang->{DestPath} || 'Bad destination path';
	errmsg("${cmdname}: $msg");
	return 0;
    }
    $src="$root$src";
    $dst="$root$dst";
 my $fgid=(stat $src)[5];
    unless(isagid($args->{gid},$fgid) || $args->{isadmin}) {
	$msg=$lang->{SourceAccess} || 'Source access denied';
	errmsg("${cmdname}: $msg");
	return 0;
    }
    $fgid=(stat $dst)[5];
    if(! -d _) {
	$msg=$lang->{DestDir} || 'Destination is not a directory';
	errmsg("${cmdname}: $msg");
	return 0;
    }
    unless(isagid($args->{gid},$fgid) || $args->{isadmin}) {
	$msg=$lang->{DestAccess} || 'Destination access denied';
	errmsg("${cmdname}: $msg");
	return 0;
    }
 my $zip=Archive::Zip->new($src);
    unless ($zip) {
	$msg=$lang->{FileRead} || 'file read';
	errmsg("${cmdname}: $msg");
	return 0;
    }
 my $files=0;
 my $name;
    $dst.='/';
    for my $member ($zip->members()) {
	($name=$dst).=$member->fileName();
	if($member->isDirectory()) {
	    mkdir $name,0775;
	    chown(-1,$fgid,$name);
            next;
	}
	unless($member->extractToFileNamed($name)==AZ_OK) {
	    errmsg("$cmdname: $name");
	    return 0;
	}
	chown(-1,$fgid,$name);
	++$files;
    }
    $r->log->notice(__PACKAGE__." $args->{user}: Unzip: $src files=$files");
    1;
}

sub Move {
 my ($r,$args,$cfg,$root,$src,$dst) = @_;
 my $target=$src;
    $src="$root$src";
    $dst="$root$dst";
    use File::Copy qw(move);
 my $lang = new Apache::Language($r) if $cfg->{language};
 my $msg;
 my $cmdname=$lang->{Move} || 'Move';
    chomp $cmdname;
    unless($target) {
	$msg=$lang->{DestPath} || 'Bad destination path';
	errmsg("${cmdname}: $msg");
	return 0;
    }
 my $srcgid=(stat $src)[5];
 my $src_is_dir=1 if -d _;
    unless(isagid($args->{gid},$srcgid) || $args->{isadmin}) {
	$msg=$lang->{SourceAccess} || 'Source access denied';
	errmsg("${cmdname}: $msg");
	return 0;
    }
 my $dstgid=(stat $dst)[5];
    unless(isagid($args->{gid},$dstgid) || $args->{isadmin}) {
	$msg=$lang->{DestAccess} || 'Destination access denied';
	errmsg("${cmdname}: $msg");
	return 0;
    }
    $target=~s:^.*/(.*):$1:;
    $dst="$dst/$target" if $src_is_dir;
    unless(File::Copy::move($src, $dst)) {
	errmsg("${cmdname}: $!");
	return 0;
    }
    chown(-1,$dstgid,$dst) unless $args->{isadmin}; # admin can move others
    $r->log->notice(__PACKAGE__." $args->{user}: Move: $src->$dst");
    1;
}

sub Rename {
 my ($r,$args,$cfg,$root,$src,$dst) = @_;
 my $target=$dst;
    $src="$root$src";
    $dst="$root$dst";
    use File::Copy qw(move);
 my $lang = new Apache::Language($r) if $cfg->{language};
 my $msg;
 my $fgid=(stat $src)[5];
 my $cmdname=$lang->{Rename} || 'Rename';
    chomp $cmdname;
    unless(isagid($args->{gid},$fgid) || $args->{isadmin}) {
	$msg=$lang->{SourceAccess} || 'source access denied';
	errmsg("${cmdname}: $msg");
	return 0;
    }
    unless($target) {
	$msg=$lang->{DestPath} || 'Bad destination path';
	errmsg("${cmdname}: $msg");
	return 0;
    }
    if(-e $dst) {
	$msg=$lang->{DestExists} || 'Destination';
	errmsg("${cmdname}: $msg");
	return 0;
    }
    unless(File::Copy::move($src, $dst)) {
	errmsg("${cmdname}: $!");
	return 0;
    }
    $r->log->notice(__PACKAGE__." $args->{user}: Rename: $src->$dst");
    1;
}

###################################################################
# The following override is requried because File::NCopy uses glob
# which can not deal with spaces in the file names.
###################################################################
package File::NCopy;
use subs qw(glob);
sub glob {@_};
package Apache::OpenIndex;
###################################################################
sub Copy {
 my ($r,$args,$cfg,$root,$src,$dst) = @_;
 my $target=$src;
    $src="$root$src";
    $dst="$root$dst";
    use File::NCopy qw(copy);
 my $lang = new Apache::Language($r) if $cfg->{language};
 my $msg;
 my $cmdname=$lang->{Copy} || 'Copy';
    chomp $cmdname;
    unless($target) {
	$msg=$lang->{DestPath} || 'Bad destination path';
	errmsg("${cmdname}: $msg");

OpenIndex.pm view on Meta::CPAN

	$msg=$lang->{SourcePath} || 'Bad source path';
	errmsg("${cmdname}: $msg");
	return 0;
    }
    unless(isagid($args->{gid},$fgid) || $args->{isadmin}) {
	$msg=$lang->{SourceAccess} || 'Source access denied';
	errmsg("${cmdname}: $msg");
	return 0;
    }
    if(-d _) {
	unless(File::Path::rmtree($src)) {
	    errmsg("${cmdname}: $!");
	    return 0;
	}
    } else {
	unless(unlink($src)) {
	    errmsg("${cmdname}: $!");
	    return 0;
	}
    }
    $r->log->notice(__PACKAGE__." $args->{user}: Delete: $src");
    1;
}

sub Upload {
 my ($r,$args,$cfg,$root,$src,$dst) = @_;
 my $upload=$r->upload;
 my $sfh=$upload->fh;
 my $bytes=0;
 my $size=0;
 my $lang = new Apache::Language($r) if $cfg->{language};
 my $msg;
 my $cmdname=$lang->{Upload} || 'Upload';
    chomp $cmdname;
    $src=~s:.*[\\/]::o; # strip off the UNIX or DOS filename
    $dst="$root$dst$src";
    unless($sfh) {
	$msg=$lang->{internal} || 'internal';
	errmsg("${cmdname}: $msg");
	return 0;
    }
 my $fgid=parentok($dst,$args,$cfg,$cmdname,$lang);
    return 0 unless $fgid; 
    unless(open DFH, ">$dst") {
	$msg=$lang->{DestOpen} || 'Destination open';
	errmsg("${cmdname}: $msg");
	return 0;
    }
 my $buf;
    while(($size=read($sfh, $buf, 4096))) {
	unless(print DFH $buf) {
	    close DFH;
	    $msg=$lang->{write} || 'write';
	    errmsg("${cmdname}: $msg");
	    return 0;
	}
	$bytes+=$size;
    }
    $args->{bytes}+=$bytes;
    close DFH;
    chown(-1,$fgid,$dst);
    $r->log->notice(__PACKAGE__." $args->{user}: Upload: $bytes: $src->$dst");
    1;
}

sub View {
 my ($r,$args,$cfg,$root,$src,$dst) = @_;
    $src.="?frame=$args->{frame}" if($args->{frame});
    $r->log->notice(__PACKAGE__." View: $args->{user}: $src");
    $r->header_out(Location=>$src);
    return REDIRECT;
}
# End of internal menu command routines

# Start of internal proc call back routines
sub EditSave {
 my ($r,$args,$cfg,$docroot)=@_;
 my $file="$docroot$args->{edit}";
    if($args->{save}) {
     my $lang = new Apache::Language($r) if $cfg->{language};
     my $msg;
     my $exists=1 if -e $file;
     my $cmdname=$lang->{EditSave} || 'EditSave';
	chomp $cmdname;
	unless(open FILE, ">$file") {
	    $msg=$lang->{FileOpen} || 'File Open';
	    errmsg("${cmdname}: $msg");
	    return ERROR;
	} else {
	    print FILE $args->{text};
	    close FILE;
	    unless($exists) {
	     my ($parent)=$file=~m:(^.*)/.+:o;
	     my $fgid=(stat $parent)[5];
		chown(-1,$fgid,$file);
	    }
	    $r->log->notice(__PACKAGE__." $args->{user}: EditSave: $file");
	}
    }
    editini($r,$args,$file,"$docroot$args->{info}");
}

sub editini {
 my ($r,$args,$file,$inifile)=@_;
    if($args->{save} || $args->{user} eq $args->{saver}) {
	if($args->{save}) {
	    unless(open INIFILE, ">$inifile") {
		errmsg("Edit: Lock File write open");
		$args->{error}=1;
	    } else {
		unless(flock INIFILE, LOCK_EX|LOCK_NB) {
		    errmsg("Edit: Couldn't lock file.  Try again");
		    $args->{error}=1;
		} else {
		 my $fgid=(stat $file)[5];
		    $fgid=getgrgid $fgid || $fgid;
		    print INIFILE "editedby=$args->{user}\ngid=$fgid\ntime=",scalar localtime,"\nstatus=in\n";
		}
	    }
	} else {
	    unless(open INIFILE, ">>$inifile") {
		errmsg("Edit: Lock File append open");
		$args->{error}=1;
	    } else {
		unless(flock INIFILE, LOCK_EX|LOCK_NB) {
		    errmsg("Edit: Couldn't lock file.  Try again");
		    $args->{error}=1;
		} else {
		    print INIFILE "status=in\n";
		}
	    }
	}
	flock INIFILE,LOCK_UN;
	close INIFILE;
	delete $args->{text};
    }
    1;
}

sub Revokem {
 my ($r,$args,$cfg,$docroot) = @_;
    return 0 if $args->{return};
 my $lang = new Apache::Language($r) if $cfg->{language};
 my $msg='';
 my $cmdname=$lang->{Revoke} || 'Revoke';
 my $revgid=$args->{id} if $args->{enagid} || $args->{disgid};
 my $revuser=$args->{id} if $args->{enauid} || $args->{disuid};
 my $file="$docroot$args->{root}$cfg->{fakedir}".REVOKE_DIR;
       $file.=REVOKE_FILE;
    if($revgid=~m:[A-Za-z]:o) {
	$revgid=getgrnam $revgid;
    }
    if($revuser eq $args->{user} || $revgid==$cfg->{admin}) {
	$r->warn(__PACKAGE__ . " revoke self not allowed");
	errmsg("admin IDs can not be revoked");

OpenIndex.pm view on Meta::CPAN

    print qq~<input type="hidden" name="group" value="$args->{group}" />\n~ if $args->{group};
    print qq~<input type="hidden" name="frame" value="$args->{frame}" />\n~ if $args->{frame};
}

sub substrcnt {
 my ($str,$substr,$offset) =@_;
 my ($cnt,$ndx);
 my $sublen=length $substr;
    for($cnt=0; ($ndx=index($str,$substr,$offset))>=0; $cnt++) {
	$offset=$ndx+$sublen;
    }
    $cnt;
}

sub parentok {
 my ($str,$args,$cfg,$cmd,$lang)=@_;
 my ($parent)=$str=~m:(^.*)/.+:o;
 my $fgid=(stat $parent)[5];
    unless(isagid($args->{gid},$fgid) || $args->{isadmin}) {
	my $msg=$lang->{ParentAccess} || 'Parent access denied';
	errmsg("${cmd}: $msg");
	return 0;	# root(0) gid is always not allowed
    }
    $fgid;
}


sub dirbound {
 my ($dir, $root)=@_;
 my $level=substrcnt($root,'/');
 my $cnt=0;
    while($dir=~m:/:go) {
	$cnt++;
	if($dir=~m:\G\.\.(/|$):o) {
	    return 0 if --$cnt<$level;
	    $cnt-- if m:\G\.\./:o;
	}
    }
    1;
}

sub getcmd {
 my ($c, $a)=@_;
    foreach (@$c) {
	return $_ if $a->{$_};
    }
    '';
}

sub isagid {
 my ($gid,$check)=@_;
    return 0 unless $check;		# never allow a root(0) gid
    return 1 unless $gid && @$gid;	# always a member if no gid 
    for(my $cnt=@$gid-1;$cnt>=0;$cnt--) {
	return 1 if $gid->[$cnt]==$check;
    }
    0;
}

sub chgid {
    chown(-1,$chgid,$_[1]) if $chgid;
    1;
}

sub outfile {
 my ($file,$suppress) = @_;
 my $buf;
    return 0 unless(open OFILE, "<$file");
    while(<OFILE>) {
	if($suppress) {
	    s:</?html.*>\s*::oi if m:</?html[\s>]:oi;
	    s:</?body.*>\s*::oi if m:</?body[\s>]:oi;
	    if(m:<head[\s>]:oi) {
		do {
		    if(m:</head>:oi) {
			s:.*</head>\s*::oi;
			goto SHOW;
		    }
		} while(<OFILE>);
	    }
	}
    SHOW: print;
    }
    close OFILE;
    1;
}

sub errmsg {
    return $errmsg unless defined $_[0];
    ($errmsg)=shift;
    chomp $errmsg;
}

sub getrevoked {
 my ($r,$args,$file)=@_;
 my $server=$r->get_server_name;
 my $key;
    print STDERR "getrevoked() file=$file\n" if $debug;
    if(open REVOKED, $file) {
	while(<REVOKED>) {
	 my ($type,$val)=m:(\w+)=(\w+):;
	    if($type eq 'gid' && $val=~m:[^0-9]:o) {
		$val=getgrnam $val || $val;
	    }
	    $val = lc $val;
	    $key=$type eq 'user'?"$val#":'#';
	    $key.=$type eq 'gid' ?"$val#":'#';
	    $key.="${server}#$args->{root}";
	    print STDERR "getrevoked() found $type=$val key=$key\n" if $debug;
	    $users->{"$key"}='-';
	}
	close REVOKED;
    } else {
	print STDERR "getrevoked() open FAILED: $file\n" if $debug;
    }
}

sub place_doc {
 my ($r,$cfg,$docs) = @_;
 my $uri = $r->uri;
 my $ofile;

( run in 1.014 second using v1.01-cache-2.11-cpan-71847e10f99 )