Reorganise more files into subdirectories and add CPAN support via Module::Build
This commit is contained in:
Adam Spiers
parent
382ad5c58d
commit
58625800ee
15 changed files with 369 additions and 95 deletions
108
bin/chkstow.in
Executable file
108
bin/chkstow.in
Executable file
|
|
@ -0,0 +1,108 @@
|
|||
#!@PERL@
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
require 5.6.1;
|
||||
|
||||
use File::Find;
|
||||
use Getopt::Long;
|
||||
|
||||
our $Wanted = \&bad_links;
|
||||
our %Package=();
|
||||
our $Stow_dir = '';
|
||||
our $Target = q{/usr/local/};
|
||||
|
||||
# put the main loop into a block so that tests can load this as a module
|
||||
if ( not caller() ) {
|
||||
if (@ARGV == 0) {
|
||||
usage();
|
||||
}
|
||||
process_options();
|
||||
#check_stow($Target, $Wanted);
|
||||
check_stow();
|
||||
}
|
||||
|
||||
sub process_options {
|
||||
GetOptions(
|
||||
'b|badlinks' => sub { $Wanted = \&bad_links },
|
||||
'a|aliens' => sub { $Wanted = \&aliens },
|
||||
'l|list' => sub { $Wanted = \&list },
|
||||
't|target=s' => \$Target,
|
||||
) or usage();
|
||||
return;
|
||||
}
|
||||
|
||||
sub usage {
|
||||
print <<"EOT";
|
||||
USAGE: chkstow [options]
|
||||
|
||||
Options:
|
||||
-b, --badlinks Report symlinks that point to non-existant files.
|
||||
-a, --aliens Report non-symlinks in the target directory.
|
||||
-l, --list List packages in the target directory.
|
||||
-t DIR, --target=DIR Set the target directory to DIR (default
|
||||
is /usr/local)
|
||||
EOT
|
||||
exit(0);
|
||||
}
|
||||
|
||||
sub check_stow {
|
||||
#my ($Target, $Wanted) = @_;
|
||||
|
||||
my (%options) = (
|
||||
wanted => $Wanted,
|
||||
preprocess => \&skip_dirs,
|
||||
);
|
||||
|
||||
find(\%options, $Target);
|
||||
|
||||
if ($Wanted == \&list) {
|
||||
delete $Package{''};
|
||||
delete $Package{'..'};
|
||||
|
||||
if (keys %Package) {
|
||||
print map "$_\n", sort(keys %Package);
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub skip_dirs {
|
||||
# skip stow source and unstowed targets
|
||||
if (-e ".stow" || -e ".notstowed" ) {
|
||||
warn "skipping $File::Find::dir\n";
|
||||
return ();
|
||||
}
|
||||
else {
|
||||
return @_;
|
||||
}
|
||||
}
|
||||
|
||||
# checking for files that do not link to anything
|
||||
sub bad_links {
|
||||
-l && !-e && print "Bogus link: $File::Find::name\n";
|
||||
}
|
||||
|
||||
# checking for files that are not owned by stow
|
||||
sub aliens {
|
||||
!-l && !-d && print "Unstowed file: $File::Find::name\n";
|
||||
}
|
||||
|
||||
# just list the packages in the the target directory
|
||||
# FIXME: what if the stow dir is not called 'stow'?
|
||||
sub list {
|
||||
if (-l) {
|
||||
$_ = readlink;
|
||||
s{\A(?:\.\./)+stow/}{}g;
|
||||
s{/.*}{}g;
|
||||
$Package{$_} = 1;
|
||||
}
|
||||
}
|
||||
|
||||
1; # Hey, it's a module!
|
||||
|
||||
# Local variables:
|
||||
# mode: perl
|
||||
# End:
|
||||
# vim: ft=perl
|
||||
282
bin/stow.in
Executable file
282
bin/stow.in
Executable file
|
|
@ -0,0 +1,282 @@
|
|||
#!@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
|
||||
Loading…
Add table
Add a link
Reference in a new issue