view release on metacpan or  search on metacpan

bin/fetchware  view on Meta::CPAN

    # Must parse the Fetchwarefile in the parent, so that the parent has access
    # to the imported subroutines and modified fetchware configuration (%CONFIG)
    # just as the child does.
    parse_fetchwarefile($fetchwarefile);
    vmsg "Parsed Fetchwarefile [$$fetchwarefile].";

    # start() runs as root before the fork, because it uses
    # App::Fetchware::Util's create_tempdir() to create a $temp_dir. This
    # subroutine uses a variable to store an open filehandle to a
    # "fetchware.sem" semaphore file. This filehandle must stay open and locked
    # using flock, because otherwise a "fetchware clean" run could delete the
    # temporary directory out from under fetchware. Therefore, the parent must
    # open this semaphore, because the child if it runs start() will close this
    # file handle when it exits causing cleanup_tempdir() to freak out when
    # end() is called.
    my $temp_dir = start();

    # "Download" the package using File::Copy's cp().
    my $package_path;
    if (cp($fetchware_package_path, $temp_dir)) {
        # Determine the output file that cp() used.
        ###BUGALERT### Open the file for cp(), and provide cp() with a
        #filehandle to write the data to to ensure the filename is exactly
        #what it needs to be.
        $package_path = catfile($temp_dir,
            file($fetchware_package_path)->basename());
    } else {
        die <<EOD;
fetchware: Fetchware failed to copy the file [$fetchware_package_path] to the
destination directory [$temp_dir]. OS error [$!].
EOD
    }


    vmsg "Copied installed package to temporary directory at [$package_path]";

    my $build_path = unarchive($package_path);

    uninstall($build_path);

    end();

    vmsg 'Uninstalling fetchware package from fetchware database.';
    uninstall_fetchware_package_from_database($fetchware_package_path);

    msg "Uninstalled fetchware package [$uninstall_package_path].";
    # Return the name of the uninstalled package's full path fetchware's
    # database.
    return $fetchware_package_path;
}



###BUGALERT### Move cmd_new() before install()?????
###BUGALERT### Print out fetchware's assumptions it makes about what FTP & hTTP
#lookup_url's look like, versionstring's assumptions, timestamp's assumptions,
#verify's assumptions, and so on. If not here in new() at least do it in the
#POD documentation.
###BUGALERT### Support ~/.Fetchwarefile, or whatever File::HomeDir wants it to
#be. Test if ~/.Fetchwarefile exists, if it does do nothing, but if it does not
#exist then prompt the user to fill one out!!!

############BUGALERT########################BUGALERT##################
############BUGALERT########################BUGALERT##################
###BUGALERT### Modify analyze_lookup_listing() to print the directory listing
#for the user to peruse, and have the user choose what program they want to
#install from the listing. Then use that as the basis for the filter option.
#httpd-2.4.1.tar.bz2 would simply be m/(\w+?)[.-_\d]+?/ And $1 is the filter
#option. If the match fails to the existing manual crap.
############BUGALERT########################BUGALERT##################
############BUGALERT########################BUGALERT##################

###BUGALERT### Add a command line option to fetchware new that allows users to
#only edit a blank file (Have helpful comments about what options are must
#haves), and then have fetchware ask the user if they would like to then install
#that new Fetchwarefile.
###BUGALERT### Rename lookup_url to main_mirror or master_mirror or author_mirror
#or something to better implicitly explain what it is.
###BUGALERT### Add the check to see if there is a MIRRORS file or some similar
#regex, and if so parse it, and auto add it to the list of mirrors? Is this
#really feasible?


sub cmd_new {

    # These are the variables that the child must share back with the parent.
    my $program_name = shift; # The child might change or define it again.

    my $term = Term::ReadLine->new('Fetchware new');

    # Must ask user what App::Fetchware extension they are going to create a
    # Fetchwarefile for, so I can load that extension's new() and new_install()
    # API subroutines, because *no* API subroutines are available until
    # parse_fetchwarefile() is called in cmd_install(), and I can't call
    # parse_fetchwarefile() before the user has answered the questons to
    # actually create a Fetchwarefile.
    my $fetchware_extension = $term->get_reply(
        print_me => <<EOP,
Unless you're using a Fetchware extension, press enter to continue along in the
creation of your new Fetchwarefile. If you are using a Fetchware extension,
please enter its name without the 'App::FetchwareX::' prefix.
EOP
        prompt => q{Unless you're using a Fetchware extension press enter to use default?},
        default => 'App::Fetchware',
    );

    ###Security Note### Whatever string the user supplies will be given
    #to Module::Load's load() subroutine, and then forwarded on to
    #Perl's require() function, which parses and executes it as far as
    #loading it goes, and then whatever new() and new_install()
    #subroutines will be imported in the current package, and later one
    #executed below new() with dropped privs, and new_install() as root
    #if fun as root. You may consider this a security hole as it is
    #never a good idea to execute user specified code, but considering
    #later on cmd_new() via new() will ask the user if they want to edit
    #the Fetchwarefile, where they can put whatever Perl code in it they
    #want to, and then ask_to_install_now_to_test_fetchwarefile() will
    #actually then run that Fetchwarefile, so that is also a security
    #hole. However none of this  really is a security hole, because the
    #user could create a Perl program that does whatever bad stuff that
    #they could use this to mess with Fetchware for.
    ###Do basic security checking anyway.
    die <<EOD if $fetchware_extension =~ m!\.\./|/|.pl|.pm!;
fetchware: The Fetchware extension you provided has characters that are not
allowed in fetchware extensions such as [../ , / , .pl , or .pm]. Please remove
these characters, and try again.
EOD
    if (grep { $fetchware_extension eq $_ }
        qw(App::Fetchware Fetchware fetchware default Default)
    ) {
        load 'App::Fetchware', qw(new new_install);
    } else {
        # Prepend the App::FetchwareX:: prefix for all fetchware
        # extensions.
        $fetchware_extension = "App::FetchwareX::$fetchware_extension";

        load $fetchware_extension, qw(new new_install);
    }

    

    # Drop privs, so only install() is called with root permissions
    my $output = drop_privs( sub {
        my $write_pipe = shift;


        my @pipe_args = new($term, $program_name);

        # Tell the parent, root, process the values of the variables the
        # child calculated in this coderef, and write them across this pipe
        # back to the parent
        write_dropprivs_pipe($write_pipe, @pipe_args);
    }, config('user'),
    # cmd_new() does not want or need the directory that drop_privs() creates
    # for the child so that the child can write files inside the parent's
    # temporary directory that was created with start().
    SkipTempDirCreation => 1
    ); # End drop_privs() back to root now!


    # Read from the pipe the child, the drop_privs()ed process, writes to to
    # read the necessary values that correspond to the variables that the
    # child must communicate back to the parent, so the parent can continue

bin/fetchware  view on Meta::CPAN

        if ($> == 0) {
            # Fetchware is modeled slightly after Slackware's package manager,
            # which keeps its package database under /var/log/packages.
            $fetchware_database_path = '/var/log/fetchware';
        # else use a "user" directory.
        } else {
            $fetchware_database_path
                =
                File::HomeDir->my_dist_data('fetchware', { create => 1 });
        }
    } elsif ($^O eq "MSWin32") {
        # Load main Windows module to use to see if we're Administrator or not.
        BEGIN {
            if ($^O eq "MSWin32")
            {
                require Win32;
                Win32->import();  # assuming you would not be passing arguments to "use Module"
            }
        }
        if (Win32::IsAdminUser()) {
            # Is this an appropriate default?
            $fetchware_database_path = 'C:\Fetchware'; 
        } else {
            $fetchware_database_path
                =
                File::HomeDir->my_dist_data('fetchware' , { create => 1 });
        }
    # Fall back on File::HomeDir's recommendation if not "Unix" or windows.
    ###BUGALERT### Is this appropriate for Mac OSX???? /Fetchware perhaps?????
    } else {
         $fetchware_database_path
            =
            File::HomeDir->my_dist_data('fetchware', { create => 1 });
    }
    vmsg <<EOM;
Determined fetchware database path to be: [$fetchware_database_path]
EOM
    return $fetchware_database_path;
}



sub determine_fetchware_package_path {
    my $fetchware_package = shift;
my ($package, $filename, $line) = caller;
    my $fetchware_db_glob = catfile(fetchware_database_path(), '*');

    my @fetchware_package_filenames
        =
        grep /$fetchware_package/, glob $fetchware_db_glob;

    die <<EOD if @fetchware_package_filenames == 0;
fetchware: Fetchware failed to determine the fetchware package that is
associated with the argument that you provided to fetchware
[$fetchware_package]. In this case, fetchware only allows arguments for
fetchware packages that have already been installed. Please run fetchware list
to obtain a list of installed packages to choose from.
EOD

    ###BUGALERT### Use Term::UI, and output a numbered list for the user to
    #choose from using a prompt, and then rerun upgrade with that argument.
    if (@fetchware_package_filenames > 1) {
        # Print beginning of message to STDERR.
        warn <<EOW;
fetchware: Too many installed packages match the argument you provided to the
upgrade command. Your argument was [$fetchware_package], and the multiple
results it returned were:
EOW

        # Print modified array values to STDERR.
        for (@fetchware_package_filenames) {
            warn file($_)->basename(), "\n";
        }

        # Print closing of message to STDERR.
        die <<EOD;
Choose which package from the list above you want to upgrade, and rerun
fetchware upgrade using it as the argument for the package you want to upgrade.
EOD
    }

    # Return the first and only result.
    return $fetchware_package_filenames[0];
}



sub extract_fetchwarefile {
    my ($fetchware_package_path) = @_;

    # safe_open() the fetchware package path, which ends with .fpkg, but it
    # actually a .tar.gz.
    my $fh = safe_open($fetchware_package_path, <<EOD);
fetchware: run-time error. fetchware failed to open the Fetchwarefile you
specified on the command line [$fetchware_package_path]. Please check
permissions and try again. See perldoc App::Fetchware. OS error [$!].
EOD

    # Create a temporary file to write the ungzipped file to.
    my ($output_fh, $gunzipped_path) = tempfile("fetchware-$$-XXXXXXXXXXX",
        TMPDIR => 1, UNLINK => 1); 

    gunzip($fh => $output_fh) or die <<EOD;
fetchware: IO::Uncompress::Gunzip::gunzip failed to un gzip
[$fetchware_package_path]. Gunzip's error [$GunzipError].
EOD

    my $tar = Archive::Tar->new();

    # seek the $output_fh back to its beginning, so tar can reuse it.
    seek $output_fh, 0, SEEK_SET;

    # read in the same output filehandle that gunzip() wrote the uncompressed tar
    # file to. This prevents any race conditions, and other users from messing
    # with our version of the open file.
    $tar->read($output_fh) or die <<EOD;
fetchware: Archive::Tar failed to read in the gunziped file [$gunzipped_path]
that was previously gziped as [$fetchware_package_path].
Archive::Tar error [@{[Archive::Tar->error()]}].
EOD