App-Fetchware
view release on metacpan or search on metacpan
bin/fetchware view on Meta::CPAN
###BUGALERT### cmd_install() does *not* actually do this. Consider implementing
#it.
#If no filename was
#provided or the filename doesn't exist then, cmd_install() calls new() to create
#and install a new fetchware package.
sub cmd_install {
# These variables must be shared back to the parent from the child using
# pipe_{write,read}_newline().
my $P_build_path;
###BUGALERT### After verifying basic functionality of cmd_install wrap
#subroutine contents in a for my $filename (pop @ARGV) loop to try to
#install all given arguments that arn't command line options as parsed by
#GetOpt::Long.
### Add this loop in run(), so there is just one loop to test.
my $filename = shift;
my $output;
if (defined($filename) and -e $filename) {
msg "Starting fetchware install to install [$filename]";
# If a fpkg extract out the Fetchwarefile into a scalar, and if not a
# fetchware package to go ahead and open for reading only the Fetchware
# right now while we're perhaps still root, so we can be sure we can
# still access it.
my $fetchwarefile;
if ($filename =~ /\.fpkg$/) {
$fetchwarefile = extract_fetchwarefile($filename);
vmsg <<EOM;
Extracting out Fetchwarefile from [$filename] to [$$fetchwarefile]
EOM
} else {
my $fh = safe_open($filename, <<EOD);
fetchware: Fetchware failed to open the filename you specified to fetchware
install [$filename]. The OS error was [$!].
EOD
vmsg "Opened file [$filename] for slurping.";
# Add a \ to turn the slurped scalar into a scalar ref for calling
# parse_fetchwarefile() properly.
$fetchwarefile = \do {local $/; <$fh>};
vmsg "Slurped [$filename] into fetchware: [$$fetchwarefile]";
}
# 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();
# Drop privs, so only install() and end() are called with root perms
$output = drop_privs(
sub {
my $write_pipe = shift;
# Run the App::Fetchware API subroutines to do everything to install
# the program, but be mindful of drop_privs() requiring this coderef
# to use write_dropprivs_pipe() to communicate needed changes back to
# the parent process, for example, $P_build_path--the parent needs to
# chdir() to that directory before it tries to execute install().
###BUGALERT### install installs no matter if the program is already
#installed!!! Change this to parse out the package from the
#download_urlif possible, compare with the one in the fetchware
#package database, and call exit right here if the current version
#is already installed unless of course --force is used!!!
my $download_url = lookup();
my $package_path = download($temp_dir, $download_url);
###BUGALERT### Add support for caching the key files gpg creates to
#the fetchwarefile, and for actually using them later on inside the
#fpkg.
verify($download_url, $package_path);
$P_build_path = unarchive($package_path);
build($P_build_path);
# 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, $P_build_path);
}, config('user')
); # End drop_privs().
# 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
# processing as though no fork()ing or priv dropping took place.
($P_build_path)
= read_dropprivs_pipe($output);
my $installed_fetchware_package_path;
if (not config('no_install')) {
install($P_build_path);
vmsg "Creating Fetchware package from [@{[cwd()]}].";
my $fetchware_package_path
=
create_fetchware_package($fetchwarefile, cwd());
vmsg "Created fetchware package at [$fetchware_package_path].";
bin/fetchware view on Meta::CPAN
Installed created fetchware package to [$installed_fetchware_package_path]
EOM
}
end();
# Return the path of the created and installed fetchware package.
return $installed_fetchware_package_path;
} else {
###BUGALERT### Replace with warn for proposed for loop above to work???
die <<EOD;
fetchware: You called fetchware install incorrectly. You must also specify
either a Fetchwarefile or a fetchware package that ends with [.fpkg].
EOD
}
}
sub cmd_uninstall {
my $uninstall_package_path = shift;
msg "Uninstalling specified package [$uninstall_package_path]";
my $fetchware_package_path
= determine_fetchware_package_path($uninstall_package_path);
vmsg <<EOM;
Determined the path of this package in the fetchware database to be
[$fetchware_package_path].
EOM
# Extract out the $fetchwarefile from the $fetchware_package_path.
my $fetchwarefile;
if ($fetchware_package_path =~ /\.fpkg$/) {
$fetchwarefile
=
extract_fetchwarefile($fetchware_package_path, cwd());
vmsg <<EOM;
Extracting out Fetchwarefile from [$fetchware_package_path] to [$$fetchwarefile]
EOM
} else {
die <<EOD;
fetchware: The option you provided to uninstall is not a currently installed
fetchware package. Please rerun uninstall after determining the proper name for
the already installed fetchware package. To see a list of already installed
fetchware packages please try fetchware's list command: fetchware list
EOD
}
# 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##################
bin/fetchware view on Meta::CPAN
# process.
$term = Term::ReadLine->new('Fetchware new');
# Call App::Fetchware's or an App::Fetchware extension's new_install() to
# install the previously generated Fetchwarefile, or whatever the
# extension's new_install() does in addition to or instead of.
return new_install($term, @pipe_args);
}
###BUGALERT### Add a config sub for a command to run after upgrade.
#C<after_upgrade_commands> that will allow you to restart apache or whatever
#after you've upgraded it, so that the newest version is running after you
#upgrade, because otherwise the currently running version won't have whatever
#suecurity fixes that might have been in the previous release.
sub cmd_upgrade {
my $upgrade_name = shift;
my ($P_upgrade,
$P_build_path,
$P_download_path,
$P_fetchware_package_path);
###BUGALERT### the or --force cmdline option will skip the checking of
#version numbers, and the one lookup() says to download will be installed
#regardless.
msg "Upgrading installed fetchware package [$upgrade_name].";
$P_fetchware_package_path = determine_fetchware_package_path($upgrade_name);
vmsg <<EOM;
Determined already installed fetchware package's path to be [$P_fetchware_package_path].
EOM
# Parse out the Fetchwarefile from the fetchware package stored in the
# fetchware database directory.
my $fetchwarefile;
if ($P_fetchware_package_path =~ /\.fpkg$/) {
$fetchwarefile
= extract_fetchwarefile($P_fetchware_package_path);
vmsg "Extracted Fetchwarefile temporarily into [$fetchwarefile]";
} else {
die <<EOD;
fetchware: fetchware upgrade failed to extract the Fetchwarefile from the
fetchware package that should be stored in fetchware's database.
EOD
}
# 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();
# Drop privs, so only install() is called with root permissions
my $output = drop_privs(
sub {
my $write_pipe = shift;
###BUGALERT### Have lookup() replace the timestamp of what we should
#download too to make upgrade() be able to use the lookup_by_timestamp
#algorithm too, which is a better default anyway.
$P_download_path = lookup();
# Call upgrade() to determine if the currently available version
# ($P_download_path) is newer than the currenlty installed version
# ($P_fetchware_package_path).
my $P_upgrade = upgrade($P_download_path, $P_fetchware_package_path);
if ($P_upgrade) {
msg 'New version available upgrading now.';
my $package_path = download($temp_dir, $P_download_path);
###BUGALERT### Add support for caching the key files gpg creates to the
#fetchwarefile, and for actually using them later on inside the fpkg.
verify($P_download_path, $package_path);
$P_build_path = unarchive($package_path);
build($P_build_path);
} else {
# If a new version is not available, then the child should do
# nothing, and let the parent call end() to clean up below.
# Set $P_build_path to something that will fail, and give a decent
# error message just in case.
$P_build_path = 'Build Path not set because upgrade not needed.';
}
# 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,
$P_upgrade,
$P_build_path,
$P_download_path,
$P_fetchware_package_path
);
}, config('user')
); # End drop_privs()
# 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
# processing as though no fork()ing or priv dropping took place.
($P_upgrade,
$P_build_path,
bin/fetchware view on Meta::CPAN
push @upgraded_packages, cmd_upgrade($fetchware_package);
}
###BUGALERT### push the fetchware pacakge name and its cmd_upgrade() return
#value into a hash, and then return it or msg() it, to tell the user what
#was upgraded and what was not.
# Return 'No upgrade needed.' only if every package that was upgraded
# returned 'No upgrade needed.'.
if ( (grep { $_ eq 'No upgrade needed.'}
@upgraded_packages) eq @upgraded_packages) {
msg 'No packages need to be upgraded.';
return 'No upgrade needed.';
# Return a list of all packages that are not 'No upgrade needed.', which
# should not be returned.
} else {
my @upgraded_packages = grep { $_ ne 'No upgrade needed.' }
@upgraded_packages;
msg 'Packages were upgraded to newer versions:';
msg Dumper(\@upgraded_packages);
return @upgraded_packages;
}
}
###BUGALERT### Fix the bug that prevents look from check for an installed
#package first, then a filename or fetchwarefile.
sub cmd_look {
my $filename = shift;
my $P_look_path;
my $fetchwarefile;
if ($filename =~ /\.fpkg$/) {
$fetchwarefile = extract_fetchwarefile($filename);
vmsg <<EOM;
Extracting out Fetchwarefile from [$filename] to [$$fetchwarefile]
EOM
} else {
my $fh = safe_open($filename, <<EOD);
fetchware: Fetchware failed to open the filename you specified to fetchware
install [$filename]. The OS error was [$!].
EOD
vmsg "Opened file [$filename] for slurping.";
# Add a \ to turn the slurped scalar into a scalar ref for calling
# parse_fetchwarefile() properly.
$fetchwarefile = \do {local $/; <$fh>};
vmsg "Slurped [$filename] into fetchware: [$$fetchwarefile]";
}
# 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.
#
# Call start() with an option to have it keep the temp dir, and not
# have File::Temp clean it up with an END handler.
my $temp_dir = start(KeepTempDir => 1);
# Drop privs to match up with cmd_install()'s behavior.
my $output = drop_privs(
sub {
my $write_pipe = shift;
msg 'Downloading and unarchiving specified distribution.';
my $download_url = lookup();
my $package_path = download(cwd(), $download_url);
###BUGALERT### Add support for caching the key files gpg creates to
#the fetchwarefile, and for actually using them later on inside the
#fpkg.
verify($download_url, $package_path);
my $build_path = unarchive($package_path);
# end() is *not* run, because the point of look is to lookup,
# download, and unarchive, and then actually "look" at the files,
# and running end() would delete them.
# Compose the $P_look_path. A simple catfile($temp_dir, $build_path)
# should work, but don't forget about drop_privs() extra temporary
# directory when run as root! To avoid this problem of the $P_look_path
# being wrong when run as root due to the extra temporary directory;
# instead, of a simple catfile(...) replace the last file portion of
# $package_path, with $build_path.
$P_look_path = catfile(dir($package_path)->parent(), $build_path);
msg <<EOM;
Your package's contents are at [$P_look_path]. Please run [fetchware clean] to
delete these files and any other files fetchware may have left behind when you
are finished looking inside this package.
EOM
# 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, $P_look_path);
# Does not need to execute anything as root, because cmd_look() does not
# install anything or even call end(), because the suer is supposed to
# look at its output in the tempdir it prints out.
}, config('user')
); # End drop_privs()
# 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
# processing as though no fork()ing or priv dropping took place.
bin/fetchware view on Meta::CPAN
###BUGALERT### It could parse all installed Fetchwarefile's to obtain a listing
#of all temp_dirs that are used, and clean them as well!!!!
###BUGALERT### Use --force to parse all temp_dir's in installed packages, and
#clean them too?? Let it receive an arg to a dir to clean of fetchware crap???
sub cmd_clean {
# If user specified no specific directories to clean, then clean the default
# system tmpdir().
my @fetchware_temp_dirs = scalar @_ ? @_ : tmpdir();
my @globbed_fetchware_temp_dirs;
# Build a list of fetchware temporary directories across tmpdir() and any
# user provided paths on the command line.
for my $fetchware_temp_dir (@fetchware_temp_dirs) {
# What the user specified or tmpdir() must be a directory.
die <<EOD if not -d $fetchware_temp_dir;
fetchware: The specified directory [$fetchware_temp_dir] is not a directory or
does not exist. Please only specify directories that exist, and ones you have
read and write permission in. OS error [$!].
EOD
# Store all of the fetchware-* temp dirs in @globbed_fetchware_temp_dirs
# for later processing.
for my $fetchware_file_or_dir (
glob(catfile($fetchware_temp_dir, 'fetchware-*')),
glob(catfile($fetchware_temp_dir, 'Fetchwarefile-*'))
) {
# If it's a directory add it to the queue of directories to delete
# below.
if (-d $fetchware_file_or_dir) {
push @globbed_fetchware_temp_dirs, $fetchware_file_or_dir;
# If it's just a file just delete right away.
} else {
###BUGALERT### Should I check if the current user has perms to
#delete the file before deleting it? What about root? Should
#root delete all files found even for other users? I'll go with
#the Unix default of just doing the operation, and dealing with
#the error message you receive to avoid the complexity of
#checking perms. Furthermore, what about Unix ACLs and Windows'
#ACL style perms? It's not worth dealing with that hassel.
unlink $fetchware_file_or_dir or die <<EOD;
fetchware: Failed to unlink file [$fetchware_file_or_dir]. OS error [$!].
EOD
vmsg <<EOM;
fetchware clean found and deleted file [$fetchware_file_or_dir].
EOM
}
}
}
msg "fetchware clean found no fetchware temporary directories to clean"
if @globbed_fetchware_temp_dirs < 1;
# Holds the number of directories that had errors when they were
# deleted.
my $num_remove_tree_errors = 0;
# Number of directories remove_tree removed successfully.
my $num_remove_tree_successes = 0;
# Loop over fetchware temp dirs, and delete the ones that are not locked.
for my $temp_dir (@globbed_fetchware_temp_dirs) {
# Try to lock the 'fetchware.sem' semaphore lock file
# I annoying must open the file before I can see if I can lock it or
# not.
my $sem_lock_file = catfile($temp_dir, 'fetchware.sem');
my $fh_sem;
if (open $fh_sem, '>', $sem_lock_file) {
vmsg "Successfully created [fetchware.sem] semaphore lock file.";
} else {
# Test if the lockfile has the same owner uid as this running perl
# process, and if they differ skip deleting this one, because we
# lack the perms to do it anyway.
if ($> != (stat($sem_lock_file))[4]) {
msg "Skipping file [$sem_lock_file], because a different user created it.";
next;
} else {
die <<EOD;
App-Fetchware-Util: Failed to create [$sem_lock_file] semaphore lock file! This
should not happen, because fetchware is creating this file in a brand new
directory that only fetchware should be accessing. You simply shouldn't see this
error unless some one is messing with fetchware, or perphaps there actually is a
bug? I don't know, but this just shouldn't happen. It's so hard to trigger it to
happen, it can't easily be tested in fetchware's test suite. OS error [$!].
EOD
}
}
# Now flock 'fetchware.sem.' This should
# Use LOCK_NB so flock won't stupidly wait forever and ever until
# he lock becomes available.
# If flock fails, don't die! Instead, just skip deleting this
# fetchware temporary directory, and go on to the next one.
unless (flock $fh_sem, LOCK_EX | LOCK_NB) {
# Flock failed, something else has the lock, print message, and skip
# this directory, and go on to the next one.
msg <<EOM;
[$temp_dir] locked by another fetchware process. Skipping.
EOM
next;
}
# Delete the whole $tempdir. Use error and result for File::Path's
# experimental error handling, and set safe to true to avoid borking the
# filesystem. This might be run as root, so it really could screw up
# your filesystem big time! So set safe to true to avoid doing so.
remove_tree($temp_dir, {
error => \my $err,
result => \my $res,
safe => 1} );
# Parse remove_tree()'s insane error handling system. It's expirimental,
# but it's been experimental forever, so I can't see it changing.
if (@$err) {
$num_remove_tree_errors++;
for my $diag (@$err) {
my ($file, $message) = %$diag;
if ($file eq '') {
warn "general error: $message\n";
} else {
warn "problem unlinking $file: $message\n";
}
}
} else {
vmsg "No errors encountered during removal of [$temp_dir]\n";
}
if (@$res) {
# Keep track of each successfully removed directory.
$num_remove_tree_successes++;
vmsg "unlinked [$_]" for @$res;
}
}
# Summarize success or failure for user, so he doesn't have to dig
# through a bunch of error messages to see if it worked right.
msg <<EOM if $num_remove_tree_errors > 0;
fetchware clean had [$num_remove_tree_errors] directories give errors.
EOM
msg <<EOM if $num_remove_tree_successes > 0;
fetchware clean successfully deleted [$num_remove_tree_successes] directories.
EOM
}
sub cmd_help {
print <<'HELP';
fetchware is a package manager for source code distributions. It gives you the
ability to install, uninstall, and even upgrade your source code distributions
just like you can with your binary packages using yum, apt-get, or slackpkg.
To create a new package just use fetchware's "new" command such as:
$ fetchware new
And then answer the questions as best you can while fetchware takes your
answers and creates a Fetchwarefile for you. If your program's needs seem to
exceed the ability of fetchware's q&a configuration see perldoc App::Fetchware
( run in 0.444 second using v1.01-cache-2.11-cpan-39bf76dae61 )