view release on metacpan or  search on metacpan

lib/App/Fetchware/Util.pm  view on Meta::CPAN

# Privileges::Drop only works on Unix, so only load it on Unix.
use if is_os_type('Unix'), 'Privileges::Drop';
use POSIX '_exit';
use Sub::Mage;
use URI::Split qw(uri_split uri_join);
use Text::ParseWords 'quotewords';
use Data::Dumper;

# Enable Perl 6 knockoffs, and use 5.10.1, because smartmatching and other
# things in 5.10 were changed in 5.10.1+.
use 5.010001;

# Set up Exporter to bring App::Fetchware::Util's API to everyone who use's it.
use Exporter qw( import );

our %EXPORT_TAGS = (
    UTIL => [qw(
        msg
        vmsg
        run_prog
        no_mirror_download_dirlist
        download_dirlist
        ftp_download_dirlist
        http_download_dirlist
        file_download_dirlist
        no_mirror_download_file
        download_file
        download_ftp_url
        download_http_url
        download_file_url
        do_nothing
        safe_open
        drop_privs
        write_dropprivs_pipe
        read_dropprivs_pipe
        create_tempdir
        original_cwd
        cleanup_tempdir
    )],
);

#        create_config_options

# *All* entries in @EXPORT_TAGS must also be in @EXPORT_OK.
our @EXPORT_OK = map {@{$_}} values %EXPORT_TAGS;








###BUGALERT### Add Test::Wrap support to msg() and vmsg() so that they will
#inteligently rewrap any text they receive so newly filled in variables won't
#screw up the wrapping.
sub msg (@) {

    # If fetchware was not run in quiet mode, -q.
    unless (defined $fetchware::quiet and $fetchware::quiet > 0) {
        # print are arguments. Use say if the last one doesn't end with a
        # newline. $#_ is the last subscript of the @_ variable.
        if ($_[$#_] =~ /\w*\n\w*\z/) {
            print @_;
        } else {
            say @_;
        }
    # Quiet mode is turned on.
    } else {
        # Don't print anything.
        return;
    }
}



sub vmsg (@) {

    # If fetchware was not run in quiet mode, -q.
    ###BUGALERT### Can I do something like:
    #eval "use constant quiet => 0;" so that the iffs below can be resolved at
    #run-time to make vmsg() and msg() faster???
    unless (defined $fetchware::quiet and $fetchware::quiet > 0) {
        # If verbose is also turned on.
        if (defined $fetchware::verbose and $fetchware::verbose > 0) {
            # print our arguments. Use say if the last one doesn't end with a
            # newline. $#_ is the last subscript of the @_ variable.
            if ($_[$#_] =~ /\w*\n\w*\z/) {
                print @_;
            } else {
                say @_;
            }
        }
    # Quiet mode is turned on.
    } else {
        # Don't print anything.
        return;
    }
}






###BUGALERT### Add support for dry-run functionality!!!!
sub run_prog {
    my (@args) = @_;

    # Kill weird "Insecure dependency in system while running with -T switch."
    # fatal exceptions by clearing the taint flag with a regex. I'm not actually
    # running in taint mode, but it bizarrely thinks I am.
    for my $arg (@args) {
        if ($arg =~ /(.*)/) {
            $arg = $1;
        } else {
            die <<EOD;
php.Fetchwarefile: Match anything pattern match failed! Huh! This shouldn't
happen, and is probably a bug.
EOD
        }
    }

    # Use Text::ParseWords quotewords() subroutine to deal with spliting the
    # arguments on whitespace, and to properly quote and keep single and double
    # quotes.
    my $program;
    ($program, @args) = map {quotewords('\s+', 1, $_)} @args;

    # If fetchware is run without -q.
    unless (defined $fetchware::quiet and $fetchware::quiet > 0) {
        local $" = '][';
        vmsg <<EOM;
Running command [$program] with options [@args].
EOM
        system($program, @args) == 0 or die <<EOD;
fetchware: run-time error. Fetchware failed to execute the specified program
[$program] with the arguments [@args]. The OS error was [$!], and the return
value was [@{[$? >> 8]}]. Please see perldoc App::Fetchware::Diagnostics.
EOD
    # If fetchware is run with -q.
    } else {
        # Use a piped open() to capture STDOUT, so that STDOUT is not printed to
        # the terminal like it usually is therby "quiet"ing it.
        # If not on Windows use safer open call that doesn't work on Windows.
        unless (is_os_type('Windows', $^O)) {
            open(my $fh, '-|', "$program", @args) or die <<EOD;
fetchware: run-time error. Fetchware failed to execute the specified program
while capturing its input to prevent it from being copied to the screen, because
you ran fetchware with it's --quite or -q option. The program was [$program],
and its arguments were [@args]. OS error [$!], and exit value [$?]. Please see

lib/App/Fetchware/Util.pm  view on Meta::CPAN

    # Open the file first.
    unless (exists $opts{MODE} and defined $opts{MODE}) {
        open $fh, '<', $file_to_check or die $open_fail_message;
    } else {
        open $fh, $opts{MODE}, $file_to_check or die $open_fail_message;
    }

    my $info = stat($fh);# or goto STAT_ERROR;

    # Owner must be either me (whoever runs fetchware) or superuser. No one else
    # can be trusted.
    if(($info->uid() != 0) && ($info->uid() != $<)) {
        die <<EOD;
App-Fetchware-Util: The file fetchware attempted to open is not owned by root or
the person who ran fetchware. This means the file could have been dangerously
altered, or it's a simple permissions problem. Do not simly change the
ownership, and rerun fetchware. Please check that the file [$file_to_check] has
not been tampered with, correct the ownership problems and try again.
EOD
    }

    # Check if group and other can write $fh.
    # Use 066 to detect read or write perms.
    ###BUGALERT### What does this actually test?????
    if ($info->mode() & 022) { # Someone else can write this $fh.
        die <<EOD
App-Fetchware-Util: The file fetchware attempted to open [$file_to_check] is
writable by someone other than just the owner. Fetchwarefiles and fetchware
packages must only be writable by the owner. Do not only change permissions to
fix this error. This error may have allowed someone to alter the contents of
your Fetchwarefile or fetchware packages. Ensure the file was not altered, then
change permissions to 644.
EOD
    }
    
    # Then check the directories its contained in.

    # Make the file an absolute path if its not already.
    $file_to_check = rel2abs($file_to_check);

    # Create array of current directory and all parent directories and even root
    # directory to check all of their permissions below.
    my $dir = dir($file_to_check);
    my @directories = do {
        my @dirs;
        until ($dir eq rootdir()) {
            # Add this dir to the array of dirs to keep.
            push @dirs, $dir;

            # This loops version of $i++ the itcremeter.
            $dir = $dir->parent();
        }
        push @dirs, $dir->parent(); # $dir->parent() should be the root dir.

        # Return, by being the last statement, the list of parent dirs for
        # $file_to_check.
        @dirs;
    };
    # Who cares if _PC_CHOWN_RESTRICTED is set, check all parent dirs anyway,
    # because if say /home was 777, then anyone (other) can change any child
    # file in any directory above /home now anyway even if _PC_CHOWN_RESTRICTED
    # is set.
    for my $dir (@directories) {

        my $info = stat($dir);# or goto STAT_ERROR;

        # Owner must be either me (whoever runs fetchware) or superuser. No one
        # else can be trusted.
        if(($info->uid() != 0) && ($info->uid() != $<)) {
            die <<EOD;
App-Fetchware-Util: The file fetchware attempted to open is not owned by root or
the person who ran fetchware. This means the file could have been dangerously
altered, or it's a simple permissions problem. Do not simly change the
ownership, and rerun fetchware. Please check that the file [$file_to_check] has
not been tampered with, correct the ownership problems and try again.
EOD
        }

        # Check if group and other can write $fh.
        # Use 066 to detect read or write perms.
        ###BUGALERT### What does this actually test?????
        if ($info->mode() & 022) { # Someone else can write this $fh...
            # ...except if this file has the sticky bit set and its a directory.
            die <<EOD unless $info->mode & 01000 and S_ISDIR($info->mode);
App-Fetchware-Util: The file fetchware attempted to open [$file_to_check] is
writable by someone other than just the owner. Fetchwarefiles and fetchware
packages must only be writable by the owner. Do not only change permissions to
fix this error. This error may have allowed someone to alter the contents of
your Fetchwarefile or fetchware packages. Ensure the file was not altered, then
change permissions to 644. Permissions on failed directory were:
@{[Dumper($info)]}
Umask [@{[umask]}].
EOD
        }

    }
    # Return the proven above "safe" file handle.
    return $fh;

    # Use cool C style goto error handling. It beats copy and paste, and the
    # horrible contortions needed for "structured programming."
    STAT_ERROR: {
    die <<EOD;
App-Fetchware-Util: stat($fh) filename [$file_to_check] failed! This just
shouldn't happen unless of course the file you specified does not exist. Please
ensure files you specify when you run fetchware actually exist.
EOD
    }
}



sub drop_privs {
    my $child_code = shift;
    my $regular_user = shift // 'nobody';
    my %opts = @_;

    # Need to do this in 2 places.
    my $dont_drop_privs = sub {
        my $child_code = shift;