view release on metacpan or  search on metacpan

bin/fetchware  view on Meta::CPAN

        # 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