Re: Private Utilities

[Aristotle]

This is sm, short for Slackware make. I use it to build Slackware packages out of autoconf-based source tarballs, but half its raison d’être is to provide some defaults to the configure script, so non-Slackers might get some use out of it.

#!/usr/bin/perl

=begin plans

one class per task:
    inherit from superclass
    new():
        no getopt module
        parses args
        must know how not to consume too much!
    cmd() builds commandline

superclass:
    new() croaks
    run():
        system( $self->cmd() )
        die on error

main program is dispatcher:
    pull mode from args
    construct object
    call run()

modes:
    cd -- configure with defaults
    cf -- configure (no defaults)
    ch -- configure --help
    mk -- build
    pk -- package

in configure modes:
    += => --enable-
    -= => --disable-
    -: => --with-
    +: => --without-

=end plans

=head1 NAME

=head1 SYNOPSIS

=head1 DESCRIPTION

=head1 ARGUMENTS

=over 4

=item B<-h>, B<--help>

=item B<--man>

=item B<-c>, B<--configure>

=item B<-m>, B<--make>

=item B<-p>, B<--package>

=item B<-i>, B<--install>

=back

=head1 OPTIONS

=over 4

=item B<-n>, B<--dry-run>

=item B<-N>, B<--pkg-name>

=item B<-E>, B<--ac-enable>

=item B<-D>, B<--ac-disable>

=item B<-W>, B<--ac-with>

=item B<-O>, B<--ac-without>

=item B<-V>, B<--ac-var>

=item B<--pkg-info>

=back

=head1 SEE ALSO

=head1 AUTHORS

Aristotle Pagaltzis

=head1 COPYRIGHT

This script is free software; you can redistribute it and/or modify it
+ under the same terms as Perl itself.

=cut

use strict;
use warnings;

use Pod::Usage;
use Getopt::Long 2.24, qw( :config bundling no_ignore_case no_auto_abb
+rev );

use Cwd;
use File::Spec::Functions qw( catdir catfile tmpdir );
use File::Basename;
use File::Temp qw( mkdtemp );
use File::Path;
use POSIX qw( strftime );

use constant PWD => getcwd();

my %pkg_info = (
    ver  => 1,
    arch => do { chomp( $_ = qx/arch/ ); $_ },
    (
        basename( PWD ) =~ /\A(.*)-(.*)\z/
        ? ( distname => $1, distver => $2 )
        : ( distname => basename( PWD ), distver => "0.nover" )
    ),
);

GetOptions(
    'h|help'         => sub { pod2usage( -verbose => 1 ) },
    'man'            => sub { pod2usage( -verbose => 2 ) },
    'c|configure:s'  => \my $opt_configure,
    'm|make:s'       => \my $opt_make,
    'p|package'      => \my $opt_package,
    'i|install'      => \my $opt_install,
    'n|dry-run'      => \my $opt_dryrun,
    'N|pkg-name=s'   => \my $opt_pkgname,
    'E|ac-enable=s'  => \my @ac_enable,
    'D|ac-disable=s' => \my @ac_disable,
    'W|ac-with=s'    => \my @ac_with,
    'O|ac-without=s' => \my @ac_without,
    'V|ac-var=s'     => \my %autoconf_var,
    'pkg-info=s'     => \%pkg_info,
    'cvs'            => sub { $pkg_info{ distver } = strftime( '%Y%m%d
+', localtime ) },
) or pod2usage( -verbose => 1 );

$opt_pkgname = join( '-', @pkg_info{ qw( distname distver arch ver ) }
+ ) . '.tgz'
    unless defined $opt_pkgname;

if( not defined $autoconf_var{ prefix } ) {
    $autoconf_var{ prefix }         ||= '/usr';
    $autoconf_var{ sysconfdir }     ||= catdir( '/etc', $pkg_info{ dis
+tname } );
    $autoconf_var{ sharedstatedir } ||= '/var/com';
    $autoconf_var{ localstatedir }  ||= '/var';
}

delete @autoconf_var{ grep !length $autoconf_var{ $_ }, keys %autoconf
+_var };

sub parse_features { map /\G ,? ( .+? (?: =.* \z | (?=,) | \z ) ) /xg,
+ @_ }

sub pull_argv {
    my @pulled;
    while ( @ARGV ) {
        my $curr = shift @ARGV;
        last if $curr eq '--';
        push @pulled, $curr;
    }
    return @pulled;
}

sub run {
    if ( $opt_dryrun ) {
        print join( ' ', @_ ), "\n";
        return 1;
    }
    return system( @_ ) == 0;
}

######################################################################
+#########
my $success = 1;
######################################################################
+#########

if ( defined $opt_configure ) {
    $success = run(
        ( -x $opt_configure ? $opt_configure : './configure' ),
        map ( "--$_=$autoconf_var{$_}", sort { length $a <=> length $b
+ } keys %autoconf_var ),
        map ( "--enable-$_",  parse_features @ac_enable ),
        map ( "--disable-$_", parse_features @ac_disable ),
        map ( "--with-$_",    parse_features @ac_with ),
        map ( "--without-$_", parse_features @ac_without ),
        pull_argv(),
    );
}

######################################################################
+#########
print( "Configure failed.\n" ), exit 1 unless $success;
######################################################################
+#########

if ( defined $opt_make ) {
    $success = run( ( -x $opt_make ? $opt_make : 'make' ), pull_argv()
+, );
}

######################################################################
+#########
print( "Make failed.\n" ), exit 1 unless $success;
######################################################################
+#########

if ( $opt_package ) {
    unless ( $opt_dryrun or $< == 0 ) {
        print STDERR "Creating package as non-root. Continue (y/n)? ";
        last unless <> =~ /^\s*y/i;
    }

    my $tmpdir = $opt_dryrun
        ? '$tmpdir'
        : mkdtemp( catdir( tmpdir, 'slakmk.XXXXXXXX' ) );

    chmod 0755, $tmpdir unless $opt_dryrun;

    my @cmd;
    ( @cmd = pull_argv() ) or ( @cmd = qw( make install DESTDIR=%d/ ) 
+);

    s/ \G ( %(.) | . ) /
        ( !defined $2 ) ? $1      :
        $2 eq '%'       ? '%'     :
        $2 eq 'd'       ? $tmpdir :
        do { warn "Unknown format sequence '$1', ignoring\n"; '' }
    /xge for @cmd;
    run( @cmd );

    chdir $tmpdir unless $opt_dryrun;

    $success =
        run( makepkg => -c => 'n', -l => 'y', catfile( PWD, $opt_pkgna
+me ) );

    chdir PWD unless $opt_dryrun;

    rmtree $tmpdir unless $opt_dryrun;
}

######################################################################
+#########
print( "Package creation failed.\n" ), exit 1 unless $success;
######################################################################
+#########

$success = run( installpkg => catfile( PWD, $opt_pkgname ) )
    if $opt_install;

######################################################################
+#########
print( "Installation failed.\n" ), exit 1 unless $success;
######################################################################
+#########

This is rat – because “tar” is backwards –, which attempts to make dealing with tarballs (and zipfiles) a little saner:

#!/usr/bin/perl
use warnings;
use strict;

use Getopt::Long;
use File::Copy qw(move);
use File::Temp qw(tempdir);
use File::Basename qw(basename);
use File::Spec::Functions qw(catdir no_upwards rootdir);

use constant BASEDIR => do { require Cwd; Cwd::cwd() };

sub slurp_dir {
    my $dir = shift;
    opendir my ($dh), $dir
        or die "Couldn't read directory $dir: $!\n";
    readdir $dh;
}

sub run_cmd {
    print "\t@_\n";

    my $exit = system(@_);

    require POSIX;
    if (POSIX::WIFEXITED($exit)) {
        return 1 if POSIX::WEXITSTATUS($exit) == 0;
        print "\tReturned non-zero exit status\n";
        return;
    }
    else {
        print "\tQuitting: Subprocess exited abnormally\n";
        exit 1;
    }
}

sub mangle_targetdir {
    my ($exdir) = @_;

    my $basedir_rx = join '.?', map quotemeta, split /[-_ ]/, $exdir;

    my ($tarbase, @morefiles) = no_upwards(slurp_dir $exdir);

    my $exdir_tar = catdir($exdir, $tarbase);

    if (@morefiles or ! -d $exdir_tar or $tarbase !~ /\A$basedir_rx/i)
+ {
        print "\tExtracted in $exdir\n";
        return;
    }

    print "\tExtracted in $tarbase\n"
        if $tarbase ne $exdir;

    my $tempdir = tempdir(DIR => BASEDIR);
    my $tempdir_tar = catdir($tempdir, $tarbase);
    my $basedir_tar = catdir(BASEDIR, $tarbase);

    move $exdir_tar, $tempdir_tar
        and rmdir $exdir
        and move $tempdir_tar, $basedir_tar
        and rmdir $tempdir
        or print "\tFailed moving $exdir_tar to $basedir_tar: $!\n";
}

sub run_in_dir {
    my $basename = basename shift;
    mkdir $basename;
    run_cmd(@_);
    mangle_targetdir($basename);
}

GetOptions(
    'list|l!'      => \(my $list      = ''),
    'overwrite|o!' => \(my $overwrite = ''),
    'remove|r!'    => \(my $remove    = ''),
) and @ARGV or die "usage: FIXME\n"; # FIXME

my %ext = $list
    ? (
        zip  => sub { local %_ = @_; unzip => -l => $_{archive} },
        tar  => sub { local %_ = @_; tar => tv =>               -f => 
+$_{archive}, },
        tgz  => sub { local %_ = @_; tar => tv => '--gzip',     -f => 
+$_{archive}, },
        tbz2 => sub { local %_ = @_; tar => tv => '--bzip2',    -f => 
+$_{archive}, },
        tarz => sub { local %_ = @_; tar => tv => '--compress', -f => 
+$_{archive}, },
    )
    : (
        zip  => sub { local %_ = @_; unzip => -q => -d => $_{dir}, $_{
+archive} },
        tar  => sub { local %_ = @_; tar => x =>               -f => $
+_{archive}, -C => $_{dir}, },
        tgz  => sub { local %_ = @_; tar => x => '--gzip',     -f => $
+_{archive}, -C => $_{dir}, },
        tbz2 => sub { local %_ = @_; tar => x => '--bzip2',    -f => $
+_{archive}, -C => $_{dir}, },
        tarz => sub { local %_ = @_; tar => x => '--compress', -f => $
+_{archive}, },
    );

@ext{qw(tar.gz tar.bz2 tar.z tar.Z)} = @ext{qw(tgz tbz2 tarz tarz)};

my $rx = join '|', map quotemeta, keys %ext;
$rx = qr/\A (.*) \. ($rx) \z/ix;

select(STDERR);

for (@ARGV) {
    print "\n$_:\n";
    if (-f and my ($basename, $ext) = m/$rx/) {
        $list
            ? run_cmd($ext{$ext}->(archive => $_, dir => $basename))
            : run_in_dir($basename, $ext{$ext}->(archive => $_, dir =>
+ $basename));
    }
    elsif (not $list and -d) {
        my $basename = basename catdir $_;
        my $rootdir = quotemeta rootdir;

        $basename =~ s/\A$rootdir\z/rootdir/;
        $basename .= '.tar.bz2';

        -e $basename
            ? print "$basename already exists\n"
            : run_cmd(tar => c => '--bzip2', -f => $basename, $_);
    }
    else {
        print "\tNo handler found\n";
    }
}

I’m rather unhappy with the state of both; rat has at least one annoying bug. But they work sufficiently well for me that I don’t get irritated enough to actually fix them. And that’s why they’ve remained private…

[wazoox]

Do you know checkinstall? It's a neat package building utility, and it can build Slack, Debian and RPM packages, though it's primarily a Slackware utility (it comes on slackware CDs in the /extra directory IIRC).

[Aristotle]

Yes. It needs to be run as root, so any files created in the source tree during make install as well as the resultant package tarball are owned by root, which means I can’t move the package, and sometimes cannot blow away the source tree, without root permissions. It also knows nothing of DESTDIR, so you cannot run it with fakeroot, which means make install can wreak havoc at will. (Makefiles that try to register schemata with GConf are always great fun… grr.)

[wazoox]

Well, I use it a lot and I had no problem with it so far, but I admit your script may be better :)