00dani/stow
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity
stow/stow.in

283 lines
8.7 KiB
Perl
Executable file
Raw Blame History

#!@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
Reference in a new issue View git blame Copy permalink