Beefy Boxes and Bandwidth Generously Provided by pair Networks
more useful options

Fix CPAN uploads for world writable files

by bart (Canon)
on Dec 21, 2008 at 22:33 UTC ( [id://731935]=sourcecode: print w/replies, xml ) Need Help??
Category: Utility scripts
Author/Contact Info Poke bart
Description: CPAN refuses to index tarballs with world writable files, a problem most commonly encountered by people creating CPAN distributions in Windows.

This script will fix the file modes of the files directly in the tarball. Run it right after you created the tarball, but before you upload to PAUSE.

Run with -h or --help to see allowable command line options. You need at least:

  • A filename
  • The -i option to replace the file or the -o option to save it as a new file
#!/usr/bin/perl -w
use Archive::Tar;
$Archive::Tar::DO_NOT_USE_PREFIX = 1;
use strict;

# I found it way too hard to try to make Getopt::Std and Getopt::Long 
+behave as I'd like
# It's much easier to just implement command line options parsing by h
# Careful: you cannot combine several single letter command line optio
+ns into one,
# They must stay separate.
my %opt;
while(@ARGV && $ARGV[0] =~ /^-/) {
    $_ = shift;
    s/^-i// and $opt{inplace} = $_, next;
    s/^-o// and $opt{output} = ( length $_ ? $_ : shift ), next;
    /^--?f/ and $opt{force} = 1, next;
    /^--?g[a-z]*$/ and $opt{glob} = 1, next;
    /^--?p[a-z]*$/ and $opt{quickfix} = 0, next;
    /^--?q[a-z]*$/ and $opt{quickfix} = 1, next;
    /^--?d[a-z]*$/ and $opt{dryrun} = 1, next;
    /^--?v[a-z]*$/ and $opt{verbose} = 1, next;
    last if $_ eq '--';
    warn "Unknown command line option: '$_'\n" unless /^--?[h?]/;
    die <<"^USAGE^";
  perl $0 [-i|-i.bak|-o saveas.tar.gz|-d] [-p|-q]? [-f,-g,-v]* distro.
  -i, -i.bak
    inplace fix of source file, optional suffix for name of backup of 
+original file
  -o filename
    save fixed distribution as... (file name)
    Only use this if you only have one parameter file!
    dry run, do not save the output file
    verbose mode, make it list everything it does
    Apply file globbing to argument(s) (for Windows)
    pedantic fix: look at contents of file to guess the correct file m
    This merely sets the x bits for scripts, and clears them for other
+ plain files
    quickfix, just clear world writeable bit
    force, save file even if it did not require fixing

@ARGV or die "Please provide a '.tar.gz' file as argument";
if($opt{glob}) {
    @ARGV = map { /[*?]/ ? glob( / /&&!/^"/ ? qq("$_") : $_ ) : $_ } @

unless($opt{inplace} || $opt{output} || $opt{dryrun}) {
    print "As neither option -i nor -o were given, processing mode has
+ been set to dry run\n";
    $opt{dryrun} = 1;

while(@ARGV) {
    my $dist = shift;
    $dist =~ /\.t(ar\.)?gz$/
      or die "Wrong argument: '$dist'; please provide a '.tar.gz' file
+ as argument";
    print "Loading distribution '$dist'\n" if $opt{verbose};

    my $fixes;
    my $tar = Archive::Tar->new;
    my @files = $tar->get_files;
    foreach my $file (@files) {
        my $fixedmode = my $mode = $file->mode;
        my $filetype = '';
        if($file->is_file) {
            $filetype = 'file';
            if($opt{quickfix}) {
                $fixedmode &= ~2;
            } elsif(substr(${ $file->get_content_by_ref }, 0, 2) eq '#
+!') {
                $fixedmode = 0775;
            } else {
                $fixedmode = 0664;
        } elsif($file->is_dir) {
            $filetype = 'dir';
            if($opt{quickfix}) {
                $fixedmode &= ~2;
            } else {
                $fixedmode = 0775;
        } else {
        next if $mode eq $fixedmode;
        printf "Change mode %03o to %03o for %s '%s'\n", $mode, $fixed
+mode, $filetype, $file->name
          if $opt{verbose};

    if($fixes || $opt{force}) {
        if($opt{dryrun}) {
            print "Dry run: file '$dist' would have been patched ($fix
+es fixes)\n";
        } else {
            rename $dist, "$dist$opt{inplace}" or die "Cannot rename f
+ile '$dist' to '$dist$opt{inplace}': $!"
              if defined $opt{inplace} && length $opt{inplace};
            $dist = $opt{output} if $opt{output};
            $tar->write($dist, 9);
            print "File '$dist' saved.\n";
    } else {
        print "File '$dist' didn't need fixing, skipped.\n";
Replies are listed 'Best First'.
Re: Fix CPAN uploads for world writable files
by jplindstrom (Monsignor) on Dec 22, 2008 at 13:34 UTC

Log In?

What's my password?
Create A New User
Domain Nodelet?
Node Status?
node history
Node Type: sourcecode [id://731935]
and the web crawler heard nothing...

How do I use this?Last hourOther CB clients
Other Users?
Others wandering the Monastery: (4)
As of 2024-04-22 18:41 GMT
Find Nodes?
    Voting Booth?

    No recent polls found