stow/stow.in

#!@PERL@

# GNU Stow - manage the installation of multiple software packages
# Copyright (C) 1993, 1994, 1995, 1996 by Bob Glickstein
# Copyright (C) 2000, 2001 Guillaume Morin
# Copyright (C) 2007 Kahlil Hodgson
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

use strict;
use warnings;

require 5.6.1;

use POSIX qw(getcwd);
use Getopt::Long;

use Stow;
use Stow::Util qw(parent);

my $ProgramName = $0;
$ProgramName =~ s{.*/}{};

main() unless caller();

sub main {
    my ($options, $pkgs_to_unstow, $pkgs_to_stow) = process_options();

    my $stow = new Stow(%$options);
    # current dir is now the target directory

    $stow->plan_unstow(@$pkgs_to_unstow);
    $stow->plan_stow  (@$pkgs_to_stow);

    my @conflicts = $stow->get_conflicts;

    # --verbose:   tell me what you are planning to do
    # --simulate:  don't execute planned operations
    # --conflicts: just list any detected conflicts

    if (scalar @conflicts) {
        warn "WARNING: conflicts detected.\n";
        if ($options->{'conflicts'}) {
            map { warn $_ } @conflicts;
        }
        warn "WARNING: all operations aborted.\n";
    }
    else {
        $stow->process_tasks();
    }
}


#===== SUBROUTINE ===========================================================
# Name      : process_options()
# Purpose   : parse command line options
# Parameters: none
# Returns   : (\%options, \@pkgs_to_unstow, \@pkgs_to_stow)
# Throws    : a fatal error if a bad command line option is given
# Comments  : checks @ARGV for valid package names
#============================================================================
sub process_options {
    my %options        = ();
    my @pkgs_to_unstow = ();
    my @pkgs_to_stow   = ();
    my $action = 'stow';

    unshift @ARGV, get_config_file_options();
    #$,="\n"; print @ARGV,"\n"; # for debugging rc file

    Getopt::Long::config('no_ignore_case', 'bundling', 'permute');
    GetOptions(
        \%options,
        'verbose|v:+', 'help|h', 'simulate|n|no', 'conflicts|c',
        'version|V', 'compat|p', 'dir|d=s', 'target|t=s',

        # clean and pre-compile any regex's at parse time
        'ignore=s' => 
        sub {
            # FIXME: do we really need strip_quotes here?
            my $regex = strip_quotes($_[1]);
            push @{$options{'ignore'}}, qr($regex\z);
        },

        'override=s' => 
        sub { 
            my $regex = strip_quotes($_[1]);
            push @{$options{'override'}}, qr(\A$regex);
        },

        'defer=s' => 
        sub { 
            my $regex = strip_quotes($_[1]);
            push @{$options{'defer'}}, qr(\A$regex);
        },

        # a little craziness so we can do different actions on the same line:
        # a -D, -S, or -R changes the action that will be performed on the 
        # package arguments that follow it.
        'D|delete'  => sub { $action = 'unstow' },
        'S|stow'    => sub { $action = 'stow'   },
        'R|restow'  => sub { $action = 'restow' },

        # Handler for non-option arguments
        '<>' => 
        sub {
            if ($action eq 'restow') {
                push @pkgs_to_unstow, $_[0];
                push @pkgs_to_stow, $_[0];
            }
            elsif ($action eq 'unstow') {
                push @pkgs_to_unstow, $_[0];
            }
            else {
                push @pkgs_to_stow, $_[0];
            }
        },
    ) or usage();

    usage()   if $options{'help'};
    version() if $options{'version'};

    sanitize_path_options(\%options);
    check_packages(\@pkgs_to_unstow, \@pkgs_to_stow);

    return (\%options, \@pkgs_to_unstow, \@pkgs_to_stow);
}

sub sanitize_path_options {
    my ($options) = @_;

    if (exists $options->{'dir'}) {
        $options->{'dir'}    =~ s/\A +//;
        $options->{'dir'}    =~ s/ +\z//;
    }
    else {
        $options->{'dir'} = exists $ENV{STOW_DIR} ? $ENV{STOW_DIR} : getcwd();        
    }

    if (exists $options->{'target'}) {
        $options->{'target'} =~ s/\A +//;
        $options->{'target'} =~ s/ +\z//;
    }
    else {
        $options->{'target'} = parent($options->{'dir'});
    }
}

sub check_packages {
    my ($pkgs_to_stow, $pkgs_to_unstow) = @_;

    if (not @$pkgs_to_stow and not @$pkgs_to_unstow) {
        usage("No packages to stow or unstow");
    }

    # check package arguments
    for my $package (@$pkgs_to_stow, @$pkgs_to_unstow) {
        $package =~ s{/+$}{};    # delete trailing slashes
        if ($package =~ m{/}) {
            error("Slashes are not permitted in package names");
        }
    }
}


#===== SUBROUTINE ============================================================
# Name      : get_config_file_options()  
# Purpose   : search for default settings in any .stowrc files
# Parameters: none
# Returns   : a list of default options
# Throws    : no exceptions
# Comments  : prepends the contents of '~/.stowrc' and '.stowrc' to the command
#           : line so they get parsed just like normal arguments. (This was
#           : hacked in so that Emil and I could set different preferences).
#=============================================================================
sub get_config_file_options {
    my @defaults = ();
    for my $file ("$ENV{'HOME'}/.stowrc", '.stowrc') {
        if (-r $file) {
            warn "Loading defaults from $file\n";
            open my $FILE, '<', $file 
                or die "Could not open $file for reading\n";
            while (my $line = <$FILE>){
                chomp $line;
                push @defaults, split " ", $line;
            }
            close $FILE or die "Could not close open file: $file\n";
        }
    }
    return @defaults;
}                                                              

#===== SUBROUTINE ===========================================================
# Name      : usage()
# Purpose   : print program usage message and exit
# Parameters: $msg => string to prepend to the usage message
# Returns   : n/a 
# Throws    : n/a
# Comments  : if 'msg' is given, then exit with non-zero status
#============================================================================
sub usage {
    my ($msg) = @_;

    if ($msg) {
        print "$ProgramName: $msg\n\n";
    }

    print <<"EOT";
$ProgramName (GNU Stow) version $Stow::VERSION

SYNOPSIS:

    $ProgramName [OPTION ...] [-D|-S|-R] PACKAGE ... [-D|-S|-R] PACKAGE ...

OPTIONS:

    -n, --no              Do not actually make any filesystem changes
    -c, --conflicts       Scan for and print any conflicts, implies -n
    -d DIR, --dir=DIR     Set stow dir to DIR (default is current dir)
    -t DIR, --target=DIR  Set target to DIR (default is parent of stow dir)
    -v, --verbose[=N]     Increase verbosity (levels are 0,1,2,3;
                            -v or --verbose adds 1; --verbose=N sets level)

    -S, --stow            Stow the package names that follow this option
    -D, --delete          Unstow the package names that follow this option
    -R, --restow          Restow (like stow -D followed by stow -S)
    -p, --compat          use legacy algorithm for unstowing

    --ignore=REGEX        ignore files ending in this perl regex
    --defer=REGEX         defer stowing files begining with this perl regex
                          if the file is already stowed to another package
    --override=REGEX      force stowing files begining with this perl regex
                          if the file is already stowed to another package
    -V, --version         Show stow version number
    -h, --help            Show this help
EOT
    exit defined $msg ? 1 : 0;
}

sub version {
    print "$ProgramName (GNU Stow) version $Stow::VERSION\n";
    exit 0;
}

#===== METHOD ================================================================
# Name      : strip_quotes 
# Purpose   : remove matching outer quotes from the given string
# Parameters: none
# Returns   : n/a
# Throws    : no exceptions
# Comments  : none
#=============================================================================
sub strip_quotes {
    my ($string) = @_;

    if ($string =~ m{\A\s*'(.*)'\s*\z}) {
        return $1;
    }
    elsif ($string =~ m{\A\s*"(.*)"\s*\z}) {
        return $1
    }
    return $string;
}


# Local variables:
# mode: perl
# cperl-indent-level: 4
# end:
# vim: ft=perl