view release on metacpan or  search on metacpan

bin/fetchware  view on Meta::CPAN

    #actually download or install or create any packages.
	exit 0;
}







sub parse_fetchwarefile {
    my $fetchwarefile = shift;

    # Arg $fetchwarefile must be a SCALAR ref.
    die <<EOD unless ref($fetchwarefile) eq 'SCALAR';
fetchware: parse_fetchwarefile() was called with the wrong arguments. It only
accepts and scalar references of the text of your fetchwarefile.
EOD

    # Ensure the $fetchwarefile has a use App::Fetchware somewhere in it. And be
    # sure to support fetchware extensions such as App::FetchwareX::HTMLPageSync.
    die <<EOD unless $$fetchwarefile =~ /^\s*use\s+App::FetchwareX?(::)?/m;
fetchware: The fetchwarefile you provided did not have a [use App::Fetchware]
line in it. This line is required, because it is an important part of how
fetchware uses Perl for its configuration file. Your fetchware file was.
[$$fetchwarefile]
EOD

    # Do the potentially evil eval. No Safe compartment or use ops is used. This
    # is one gigantic security hole; however, it is also how fetchware works :)
    #
    # safe_open() is used to ensure that the file the user provides is "safe" to
    # use, and is the limit of fetchware's safety features.
    eval $$fetchwarefile;

    die <<EOD if $@;
fetchware: run-time error. fetchware failed to execute the Fetchwarefile
[$$fetchwarefile] you provieded on the command line or that was packaged
with your Fetchware package (*.fpkg). The error was [$@].
EOD


    # Ensure that the specified App::Fetchware implementation exports the proper
    # subroutines.
    my %api_subs = (
        start => 1,
        lookup => 1,
        download => 1,
        verify => 1,
        unarchive => 1,
        build => 1,
        install => 1,
        uninstall => 1,
        upgrade => 1,
        check_syntax => 1,
        end => 1,
    );

    # Determine if all of the @api_subs are in sublist, the list of all subs in
    # the current package.
    # Code adapted from Perl Cookbook pg. 129.
    my (%union, %intersection);
    for my $element (keys %api_subs, sublist()) {
        $union{$element}++ && $intersection{$element}++;
    }

    # Compares the number of %intersection's to the number of %api_subs, and if
    # they're *not* equal throw an exception, so the user knows which API subs
    # are not set up right.
    if ( (grep {exists $api_subs{$_} and exists $intersection{$_}
                and $api_subs{$_} eq $intersection{$_}}
                keys %api_subs) != scalar keys %api_subs) {
        my @missing_api_subs;
        for my $api_sub (keys %api_subs) {
            if (not exists $intersection{$api_sub}
                or not defined $intersection{$api_sub}
                or ($intersection{$api_sub} == 0)
            ) {
                push @missing_api_subs, $api_sub;
            }
        }
        die <<EOD;
fetchware: The App::Fetchware module you choose in your fetchwarefile does not
properly export the necessary subroutines fetchware needs it to. These include:
start(), lookup(), download(), verify, unarchive(), build(), install(),
uninstall(), and end().
The missing subroutines are [@missing_api_subs].
EOD
    }

    # Call App::Fetchware's check_syntax() (or a App::Fetchware extension's).
    check_syntax();

    return 'Evaled config file successfully';
}



sub create_fetchware_package {
    my ($fetchwarefile,
        $unarchived_package_path,
        $dir_for_new_fpkg) = @_;

    # chdir() to my cwd's parent directory, because my cwd is currently on linux
    # /tmp/fetchware-kd883ejfe/program-1.2, and I need the program-1.2 part to
    # be in the archive's @file_list. This needs to happen even when dropping
    # privs, because drop_privs() chdir()'s before it forks putting both parent
    # and child in the same directory.
    my $previous_cwd = cwd();
    my $new_dir = dir(cwd())->parent();
    chdir($new_dir) or die <<EOD;
fetchware: run-time error. Fetchware failed to change it's working
directory to
[$new_dir] from [$previous_cwd]. The os error was [$!].
EOD

    # Turn something like /tmp/fetchware-djdjkd8382/package-1.2/Fetchware (with
    # the "Fetchwarefile" filename only sometimes being there) into just
    # "package-1.2"
    my $pc = dir($unarchived_package_path);
    my $last_dir = $pc->dir_list(-1, 1);