http://qs321.pair.com?node_id=731935
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
+and...
# 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^";
Command:
  perl $0 [-i|-i.bak|-o saveas.tar.gz|-d] [-p|-q]? [-f,-g,-v]* distro.
+tar.gz
Options:
  -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!
  -d
    dry run, do not save the output file
  -v
    verbose mode, make it list everything it does
  -g
    Apply file globbing to argument(s) (for Windows)
  -p
    pedantic fix: look at contents of file to guess the correct file m
+ode
    This merely sets the x bits for scripts, and clears them for other
+ plain files
  -q
    quickfix, just clear world writeable bit
  -f
    force, save file even if it did not require fixing
^USAGE^
}

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

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;
    $tar->read($dist);
    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;
        }
        next if $mode eq $fixedmode;
        $file->mode($fixedmode);
        $fixes++;
        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