You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
tdeadmin/knetworkconf/backends/file.pl.in

935 lines
19 KiB

#!/usr/bin/env perl
#-*- Mode: perl; tab-width: 2; indent-tabs-mode: nil; c-basic-offset: 2 -*-
# Functions for file manipulation. Find, open, read, write, backup, etc.
#
# Copyright (C) 2000-2001 Ximian, Inc.
#
# Authors: Hans Petter Jansson <hpj@ximian.com>
# Arturo Espinosa <arturo@ximian.com>
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU Library General Public License as published
# by the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU Library General Public License for more details.
#
# You should have received a copy of the GNU Library General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
use File::Path;
use File::Copy;
use File::Temp;
use Carp;
$SCRIPTSDIR = "@scriptsdir@";
$FILESDIR = "@filesdir@";
if ($SCRIPTSDIR =~ /^@scriptsdir[@]/)
{
$FILESDIR = "files";
$SCRIPTSDIR = ".";
$DOTIN = ".in";
}
require "$SCRIPTSDIR/general.pl$DOTIN";
require "$SCRIPTSDIR/report.pl$DOTIN";
$GST_FILE_READ = 1;
$GST_FILE_WRITE = 2;
# --- File operations --- #
sub gst_file_get_base_path
{
my $path = "/var/cache/setup-tool-backends";
chmod (0755, $path);
return $path;
}
sub gst_file_get_tmp_path
{
return (&gst_file_get_base_path () . "/tmp");
}
sub gst_file_get_backup_path
{
return (&gst_file_get_base_path () . "/backup");
}
sub gst_file_get_debug_path
{
return (&gst_file_get_base_path (). "/debug");
}
sub gst_file_get_data_path
{
my $path = &gst_file_get_base_path (). "/data";
chmod (0755, $path);
return $path;
}
# Give a command, and it will put in C locale, some sane PATH values and tqfind
# the program to run in the path. Redirects stderr to null.
sub get_cmd_path
{
my ($cmd) = @_;
my ($tool_name, @argline, $command, $tool_path);
($tool_name, @argline) = split("[ \t]+", $cmd);
$tool_path = &gst_file_locate_tool ($tool_name);
return -1 if ($tool_path eq "");
$command = "$tool_path @argline";
$command =~ s/\"/\\\"/g;
return $command;
}
sub gst_file_get_cmd_path
{
my ($cmd) = @_;
my $command = &get_cmd_path ($cmd);
return ("LC_ALL=C PATH=\$PATH:/sbin:/usr/sbin $command 2> /dev/null");
}
# necessary for some programs that output info through stderr
sub gst_file_get_cmd_path_with_stderr
{
my ($cmd) = @_;
my $command = &get_cmd_path ($cmd);
return ("LC_ALL=C PATH=\$PATH:/sbin:/usr/sbin $command 2>&1");
}
sub gst_file_create_path
{
my ($path, $perms) = @_;
$prems = $perms || 0770;
my @pelem;
$path =~ tr/\///s;
@pelem = split(/\//, $path); # 'a/b/c/d/' -> 'a', 'b', 'c', 'd', ''
for ($path = ""; @pelem; shift @pelem)
{
$path = "$path$pelem[0]";
mkdir($path, $perms);
$path = "$path/";
}
&gst_report_enter ();
&gst_report ("file_create_path", $_[0]);
&gst_report_leave ();
}
sub gst_file_create_path_for_file
{
my ($path, $perms) = @_;
$prems = $perms || 0770;
my @pelem;
$path =~ tr/\///s;
@pelem = split(/\//, $path); # 'a/b/c/d/' -> 'a', 'b', 'c', 'd', ''
for ($path = ""; @pelem; shift @pelem)
{
if ($pelem[1] ne "")
{
$path = "$path$pelem[0]";
mkdir($path, $perms);
$path = "$path/";
}
}
&gst_report_enter ();
&gst_report ("file_create_path", $_[0]);
&gst_report_leave ();
}
$gst_file_backup_dir_rotation_was_made = 0;
# If this is the first backup created by this tool on this invocation,
# rotate the backup directories and create a new, empty one.
sub gst_file_backup_rotate_dirs
{
my $backup_tool_dir = $_[0];
&gst_report_enter ();
if (!$gst_file_backup_dir_rotation_was_made)
{
my $i;
$gst_file_backup_dir_rotation_was_made = 1;
if (-e "$backup_tool_dir/9")
{
if (-s "$backup_tool_dir/9")
{
unlink ("$backup_tool_dir/9");
}
else
{
&gst_file_rmtree ("$backup_tool_dir/9");
}
}
for ($i = 8; $i; $i--)
{
if (stat ("$backup_tool_dir/$i"))
{
move ("$backup_tool_dir/$i", "$backup_tool_dir/" . ($i+1));
}
}
if (!stat ("$backup_tool_dir/First"))
{
&gst_file_create_path ("$backup_tool_dir/First");
&gst_file_run ("ln -s First $backup_tool_dir/1");
}
else
{
&gst_file_create_path_for_file ("$backup_tool_dir/1/");
}
&gst_report ("file_backup_rotate", $backup_tool_dir);
}
&gst_report_enter ();
}
sub gst_file_backup
{
my $backup_file = $_[0];
my $backup_tool_dir;
&gst_report_enter ();
$backup_tool_dir = &gst_file_get_backup_path () . "/$gst_name/";
&gst_file_backup_rotate_dirs ($backup_tool_dir);
# If the file hasn't already been backed up on this invocation, copy the
# file to the backup directory.
if (!stat ("$backup_tool_dir/1/$backup_file"))
{
&gst_file_create_path_for_file ("$backup_tool_dir/1/$backup_file");
copy ($backup_file, "$backup_tool_dir/1/$backup_file");
&gst_report ("file_backup_success", $backup_tool_dir);
}
&gst_report_leave ();
}
# Return 1/0 depending on file existance.
sub gst_file_exists
{
my ($file) = @_;
return (-f "$gst_prefix/$file")? 1: 0;
}
sub gst_file_open_read_from_names
{
local *FILE;
my $fname = "";
&gst_report_enter ();
foreach $name (@_)
{
if (open (FILE, "$gst_prefix/$name"))
{
$fname = $name;
last;
}
}
(my $fullname = "$gst_prefix/$fname") =~ tr/\//\//s; # '//' -> '/'
if ($fname eq "")
{
&gst_report ("file_open_read_failed", "@_");
return undef;
}
&gst_report ("file_open_read_success", $fullname);
&gst_report_leave ();
return *FILE;
}
sub gst_file_open_write_from_names
{
local *FILE;
my $name;
my $fullname;
&gst_report_enter ();
# Find out where it lives.
foreach $elem (@_) { if (stat($elem) ne "") { $name = $elem; last; } }
if ($name eq "")
{
$name = $_[0];
(my $fullname = "$gst_prefix/$name") =~ tr/\//\//s;
&gst_report ("file_open_write_create", "@_", $fullname);
}
else
{
(my $fullname = "$gst_prefix/$name") =~ tr/\//\//s;
&gst_report ("file_open_write_success", $fullname);
}
($name = "$gst_prefix/$name") =~ tr/\//\//s; # '//' -> '/'
&gst_file_create_path_for_file ($name);
# Make a backup if the file already exists - if the user specified a prefix,
# it might not.
if (stat ($name))
{
&gst_file_backup ($name);
}
&gst_report_leave ();
# Truncate and return filehandle.
if (!open (FILE, ">$name"))
{
&gst_report ("file_open_write_failed", $name);
return undef;
}
return *FILE;
}
sub gst_file_open_filter_write_from_names
{
local *INFILE;
local *OUTFILE;
my ($filename, $name, $elem);
&gst_report_enter ();
# Find out where it lives.
foreach $coin (@_)
{
if (-e $coin) { $name = $coin; last; }
}
if (! -e $name)
{
# If we couldn't locate the file, and have no prefix, give up.
# If we have a prefix, but couldn't locate the file relative to '/',
# take the first name in the array and let that be created in $prefix.
if ($prefix eq "")
{
&gst_report ("file_open_filter_failed", "@_");
return(0, 0);
}
else
{
$name = $_[0];
(my $fullname = "$gst_prefix/$name") =~ tr/\//\//s;
&gst_report ("file_open_filter_create", "@_", $fullname);
}
}
else
{
(my $fullname = "$gst_prefix/$name") =~ tr/\//\//s;
&gst_report ("file_open_filter_success", $name, $fullname);
}
($filename) = $name =~ /.*\/(.+)$/;
($name = "$gst_prefix/$name") =~ tr/\//\//s; # '//' -> '/'
&gst_file_create_path_for_file ($name);
# Make a backup if the file already exists - if the user specified a prefix,
# it might not.
if (-e $name)
{
&gst_file_backup ($name);
}
# Return filehandles. Make a copy to use as filter input. It might be
# invalid (no source file), in which case the caller should just write to
# OUTFILE without bothering with INFILE filtering.
my $tmp_path = &gst_file_get_tmp_path ();
&gst_file_create_path ("$tmp_path");
unlink ("$tmp_path/$gst_name-$filename");
copy ($name, "$tmp_path/$gst_name-$filename");
open (INFILE, "$tmp_path/$gst_name-$filename");
if (!open (OUTFILE, ">$name"))
{
&gst_report ("file_open_filter_failed", $name);
return;
}
&gst_report_leave ();
return (*INFILE, *OUTFILE);
}
sub gst_file_open_write_compressed
{
local *FILE;
my ($name, $fullname, $gzip);
$gzip = &gst_file_locate_tool ("gzip");
return undef if (!$gzip);
&gst_report_enter ();
# Find out where it lives.
foreach $elem (@_) { if (stat($elem) ne "") { $name = $elem; last; } }
if ($name eq "")
{
$name = $_[0];
(my $fullname = "$gst_prefix/$name") =~ tr/\//\//s;
&gst_report ("file_open_write_create", "@_", $fullname);
}
else
{
(my $fullname = "$gst_prefix/$name") =~ tr/\//\//s;
&gst_report ("file_open_write_success", $fullname);
}
($name = "$gst_prefix/$name") =~ tr/\//\//s; # '//' -> '/'
&gst_file_create_path_for_file ($name);
# Make a backup if the file already exists - if the user specified a prefix,
# it might not.
if (stat ($name))
{
&gst_file_backup ($name);
}
&gst_report_leave ();
# Truncate and return filehandle.
if (!open (FILE, "| $gzip -c > $name"))
{
&gst_report ("file_open_write_failed", $name);
return;
}
return *FILE;
}
sub gst_file_run_pipe
{
my ($cmd, $mode_tqmask, $stderr) = @_;
my ($command);
local *PIPE;
$mode_tqmask = $GST_FILE_READ if $mode_tqmask eq undef;
&gst_report_enter ();
if ($stderr)
{
$command = &gst_file_get_cmd_path_with_stderr ($cmd);
}
else
{
$command = &gst_file_get_cmd_path ($cmd);
}
if ($command == -1)
{
&gst_report ("file_run_pipe_failed", $command);
&gst_report_leave ();
return undef;
}
$command .= " |" if $mode_tqmask & $GST_FILE_READ;
$command = "| $command > /dev/null" if $mode_tqmask & $GST_FILE_WRITE;
open PIPE, $command;
&gst_report ("file_run_pipe_success", $command);
&gst_report_leave ();
return *PIPE;
}
sub gst_file_run_pipe_read
{
my ($cmd) = @_;
return &gst_file_run_pipe ($cmd, $GST_FILE_READ);
}
sub gst_file_run_pipe_read_with_stderr
{
my ($cmd) = @_;
return &gst_file_run_pipe ($cmd, $GST_FILE_READ, 1);
}
sub gst_file_run_pipe_write
{
my ($cmd) = @_;
return &gst_file_run_pipe ($cmd, $GST_FILE_WRITE);
}
sub gst_file_run_backtick
{
my ($cmd, $stderr) = @_;
my ($fd, $res);
if ($stderr)
{
$fd = &gst_file_run_pipe_read_with_stderr ($cmd);
}
else
{
$fd = &gst_file_run_pipe_read ($cmd);
}
$res = join ('', <$fd>);
&gst_file_close ($fd);
return $res;
}
sub gst_file_close
{
my ($fd) = @_;
close $fd if (ref \$fd eq "GLOB");
}
sub gst_file_remove
{
my ($name) = @_;
&gst_report_enter ();
&gst_report ("file_remove", $name);
if (stat ($name))
{
&gst_file_backup ($name);
}
unlink $name;
&gst_report_leave ();
}
sub gst_file_rmtree
{
my($roots, $verbose, $safe) = @_;
my(@files);
my($count) = 0;
$verbose ||= 0;
$safe ||= 0;
if ( defined($roots) && length($roots) ) {
$roots = [$roots] unless ref $roots;
}
else {
carp "No root path(s) specified\n";
return 0;
}
my($root);
foreach $root (@{$roots}) {
$root =~ s#/\z##;
(undef, undef, my $rp) = lstat $root or next;
$rp &= 07777; # don't forget setuid, setgid, sticky bits
if ( -d $root ) { # $root used to be _, which is a bug.
# this is why we are replicating this function.
# notabene: 0777 is for making readable in the first place,
# it's also intended to change it to writable in case we have
# to recurse in which case we are better than rm -rf for
# subtrees with strange permissions
chmod(0777, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
or carp "Can't make directory $root read+writeable: $!"
unless $safe;
local *DIR;
if (opendir DIR, $root) {
@files = readdir DIR;
closedir DIR;
}
else {
carp "Can't read $root: $!";
@files = ();
}
# Deleting large numbers of files from VMS Files-11 filesystems
# is faster if done in reverse ASCIIbetical order
@files = reverse @files if $Is_VMS;
($root = VMS::Filespec::unixify($root)) =~ s#\.dir\z## if $Is_VMS;
@files = map("$root/$_", grep $_!~/^\.{1,2}\z/s,@files);
$count += &gst_file_rmtree(\@files,$verbose,$safe);
if ($safe &&
($Is_VMS ? !&VMS::Filespec::candelete($root) : !-w $root)) {
print "skipped $root\n" if $verbose;
next;
}
chmod 0777, $root
or carp "Can't make directory $root writeable: $!"
if $force_writeable;
print "rmdir $root\n" if $verbose;
if (rmdir $root) {
++$count;
}
else {
carp "Can't remove directory $root: $!";
chmod($rp, ($Is_VMS ? VMS::Filespec::fileify($root) : $root))
or carp("and can't restore permissions to "
. sprintf("0%o",$rp) . "\n");
}
}
else {
if ($safe &&
($Is_VMS ? !&VMS::Filespec::candelete($root)
: !(-l $root || -w $root)))
{
print "skipped $root\n" if $verbose;
next;
}
chmod 0666, $root
or carp "Can't make file $root writeable: $!"
if $force_writeable;
print "unlink $root\n" if $verbose;
# delete all versions under VMS
for (;;) {
unless (unlink $root) {
carp "Can't unlink file $root: $!";
if ($force_writeable) {
chmod $rp, $root
or carp("and can't restore permissions to "
. sprintf("0%o",$rp) . "\n");
}
last;
}
++$count;
last unless $Is_VMS && lstat $root;
}
}
}
$count;
}
# --- Buffer operations --- #
# Open $file and put it into @buffer, for in-line editting.
# \@buffer on success, undef on error.
sub gst_file_buffer_load
{
my ($file) = @_;
my @buffer;
my $fd;
&gst_report_enter ();
&gst_report ("file_buffer_load", $file);
$fd = &gst_file_open_read_from_names ($file);
return [] unless $fd;
@buffer = (<$fd>);
&gst_report_leave ();
return \@buffer;
}
# Same with an already open fd.
sub gst_file_buffer_load_fd
{
my ($fd) = @_;
my (@buffer);
&gst_report_enter ();
&gst_report ("file_buffer_load", $file);
@buffer = (<$fd>);
&gst_report_leave ();
return \@buffer;
}
# Take a $buffer and save it in $file. -1 is error, 0 success.
sub gst_file_buffer_save
{
my ($buffer, $file) = @_;
my ($fd, $i);
&gst_report_enter ();
&gst_report ("file_buffer_save", $file);
foreach $i (@$buffer)
{
&gst_debug_print_string ("|" . $i);
}
$fd = &gst_file_open_write_from_names ($file);
return -1 if !$fd;
if (@$buffer < 1)
{
# We want to write single line.
# Print only if $buffer is NOT a reference (it'll print ARRAY(0x412493) for example).
print $fd $buffer if (!ref ($buffer));
}
else
{
# Let's print array
foreach $i (@$buffer)
{
print $fd $i;
}
}
&gst_file_close ($fd);
&gst_report_leave ();
return 0;
}
# Erase all empty string elements from the $buffer.
sub gst_file_buffer_clean
{
my $buffer = $_[0];
my $i;
for ($i = 0; $i <= $#$buffer; $i++)
{
splice (@$buffer, $i, 1) if $$buffer[$i] eq "";
}
}
sub gst_file_buffer_join_lines
{
my $buffer = $_[0];
my $i;
for ($i = 0; $i <= $#$buffer; $i++)
{
while ($$buffer[$i] =~ /\\$/)
{
chomp $$buffer[$i];
chop $$buffer[$i];
$$buffer[$i] .= $$buffer[$i + 1];
splice (@$buffer, $i + 1, 1);
}
}
}
# --- Command-line utilities --- #
# &gst_file_run (<command line>)
#
# Assumes the first word on the command line is the command-line utility
# to run, and tries to locate it, replacing it with its full path. The path
# is cached in a hash, to avoid searching for it repeatedly. Output
# redirection is appended, to make the utility perfectly silent. The
# preprocessed command line is run, and its exit value is returned.
#
# Example: "mkswap /dev/hda3" -> 'PATH=$PATH:/sbin:/usr/sbin /sbin/mkswap /dev/hda3 2>/dev/null >/dev/null'.
sub gst_file_run
{
my ($cmd, $background) = @_;
my ($command, $tool_name, $tool_path, @argline);
&gst_report_enter ();
$command = &gst_file_get_cmd_path ($cmd);
return -1 if $command == -1;
$command .= " > /dev/null";
$command .= " &" if $background;
&gst_report ("file_run", $command);
&gst_report_leave ();
# As documented in perlfunc, divide by 256.
return (system ($command) / 256);
}
sub gst_file_run_bg
{
my ($cmd) = @_;
return &gst_file_run ($cmd, 1);
}
# &gst_file_locate_tool
#
# Tries to locate a command-line utility from a set of built-in paths
# and a set of user paths (found in the environment). The path (or a negative
# entry) is cached in a hash, to avoid searching for it repeatedly.
@gst_builtin_paths = ( "/sbin", "/usr/sbin", "/usr/local/sbin",
"/bin", "/usr/bin", "/usr/local/bin" );
%gst_tool_paths = ();
sub gst_file_locate_tool
{
my ($tool) = @_;
my $found = "";
my @user_paths;
# We don't search absolute paths. Arturo.
if ($tool =~ /^\//)
{
if (! (-x $tool))
{
&gst_report ("file_locate_tool_failed", $tool);
return "";
}
return $tool;
}
&gst_report_enter ();
$found = $gst_tool_paths{$tool};
if ($found eq "0")
{
# Negative cache hit. At this point, the failure has already been reported
# once.
return "";
}
if ($found eq "")
{
# Nothing found in cache. Look for real.
# Extract user paths to try.
@user_paths = ($ENV{PATH} =~ /([^:]+):/mg);
# Try user paths.
foreach $path (@user_paths)
{
if (-x "$path/$tool" || -u "$path/$tool") { $found = "$path/$tool"; last; }
}
if (!$found)
{
# Try builtin paths.
foreach $path (@gst_builtin_paths)
{
if (-x "$path/$tool" || -u "$path/$tool") { $found = "$path/$tool"; last; }
}
}
# Report success/failure and update cache.
if ($found)
{
$gst_tool_paths{$tool} = $found;
&gst_report ("file_locate_tool_success", $tool);
}
else
{
$gst_tool_paths{$tool} = "0";
&gst_report ("file_locate_tool_failed", $tool);
}
}
&gst_report_leave ();
return ($found);
}
sub gst_file_tool_installed
{
my ($tool) = @_;
$tool = &gst_file_locate_tool ($tool);
return 0 if $tool eq "";
return 1;
}
sub gst_file_copy
{
my ($orig, $dest) = @_;
return if (!gst_file_exists ($orig));
copy ("$gst_prefix/$orig", "$gst_prefix/$dest");
}
sub gst_file_get_temp_name
{
my ($prefix) = @_;
return mktemp ($prefix);
}
sub gst_file_copy_from_stock
{
my ($orig, $dest) = @_;
if (!copy ("$FILESDIR/$orig", $dest))
{
&gst_report ("file_copy_failed", "$FILESDIR/$orig", $dest);
return -1;
}
return 0;
}
1;