From d21d1dd629f5998232615e1f4678645d8ff9a84e Mon Sep 17 00:00:00 2001 From: adam Date: Thu, 29 Dec 2005 19:17:59 +0000 Subject: [PATCH] move into Stow.pm --- stow.in | 572 +++++--------------------------------------------------- 1 file changed, 51 insertions(+), 521 deletions(-) diff --git a/stow.in b/stow.in index e46b390..fdfd773 100755 --- a/stow.in +++ b/stow.in @@ -3,6 +3,7 @@ # 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) 2005 Adam Spiers # # 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 @@ -23,528 +24,77 @@ # $Date$ # $Author$ -# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -# Wed Nov 23 2005 Adam Spiers -# This version is hacked to ignore anything listed in ~/.cvsignore +##################################################################### +# Thu Dec 29 2005 Adam Spiers +# Hacked into a Perl module +##################################################################### + +my $Version = '1.4.0'; +require 5.005; + +use strict; +use warnings; + use File::Spec; -use FindBin qw($RealBin); +use FindBin qw($RealBin $RealScript); use Getopt::Long; +use POSIX; use lib "$RealBin/../lib/perl5"; use Sh 'glob_to_re'; +use Stow; + my $ignore_file = File::Spec->join($ENV{HOME}, ".cvsignore"); my $ignore_re = get_ignore_re_from_file($ignore_file); -# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -require 5.005; -use POSIX; +my %opts = ( + conflicts => 0, + delete => 0, + not_really => 0, + verbose => 0, + stow => undef, + target => undef, + restow => 0, +); -$ProgramName = $0; -$ProgramName =~ s,.*/,,; +GetOptions( + \%opts, + 'conflicts|c', 'not_really|n', 'stow|dir|d=s', 'target|t=s', + 'verbose|v:+', 'delete|D', 'version|V', 'help|h', +) +or usage(); -$Version = '@VERSION@'; +version() if $opts{version}; +usage() if $opts{help}; -$Conflicts = 0; -$Delete = 0; -$NotReally = 0; -$Verbose = 0; -$ReportHelp = 0; -$Stow = undef; -$Target = undef; -$Restow = 0; +usage("No packages named") unless @ARGV; +Stow::SetOptions(%opts); +Stow::Init(); -# FIXME: use Getopt::Long -while (@ARGV && ($_ = $ARGV[0]) && /^-/) { - $opt = $'; - shift; - last if /^--$/; +my @Collections = @ARGV; +Stow::CheckCollections(@Collections); - if ($opt =~ /^-/) { - $opt = $'; - if ($opt =~ /^no?$/i) { - $NotReally = 1; - } elsif ($opt =~ /^c(o(n(f(l(i(c(ts?)?)?)?)?)?)?)?$/i) { - $Conflicts = 1; - $NotReally = 1; - } elsif ($opt =~ /^dir?/i) { - $remainder = $'; - if ($remainder =~ /^=/) { - $Stow = $'; # the stuff after the = - } else { - $Stow = shift; - } - } elsif ($opt =~ /^t(a(r(g(et?)?)?)?)?/i) { - $remainder = $'; - if ($remainder =~ /^=/) { - $Target = $'; # the stuff after the = - } else { - $Target = shift; - } - } elsif ($opt =~ /^verb(o(se?)?)?/i) { - $remainder = $'; - if ($remainder =~ /^=(\d+)/) { - $Verbose = $1; - } else { - ++$Verbose; - } - } elsif ($opt =~ /^de(l(e(te?)?)?)?$/i) { - $Delete = 1; - } elsif ($opt =~ /^r(e(s(t(o(w?)?)?)?)?)?$/i) { - $Restow = 1; - } elsif ($opt =~ /^vers(i(on?)?)?$/i) { - &version(); - } else { - &usage(($opt =~ /^h(e(lp?)?)?$/) ? undef : - "unknown or ambiguous option: $opt"); - } - } else { - @opts = split(//, $opt); - while ($_ = shift(@opts)) { - if ($_ eq 'n') { - $NotReally = 1; - } elsif ($_ eq 'c') { - $Conflicts = 1; - $NotReally = 1; - } elsif ($_ eq 'd') { - $Stow = (join('', @opts) || shift); - @opts = (); - } elsif ($_ eq 't') { - $Target = (join('', @opts) || shift); - @opts = (); - } elsif ($_ eq 'v') { - ++$Verbose; - } elsif ($_ eq 'D') { - $Delete = 1; - } elsif ($_ eq 'R') { - $Restow = 1; - } elsif ($_ eq 'V') { - &version(); - } else { - &usage(($_ eq 'h') ? undef : "unknown option: $_"); - } - } +if ($opts{delete} || $opts{restow}) { + Stow::Unstow('', &RelativePath($opts{target}, $opts{stow}), \@Collections); +} + +if (!$opts{delete} || $opts{restow}) { + foreach my $Collection (@ARGV) { + warn "Stowing package $Collection...\n" if $opts{verbose}; + Stow::StowContents($Collection, &RelativePath($opts{target}, $opts{stow})); } } -&usage("No packages named") unless @ARGV; - -# Changing dirs helps a lot when soft links are used -$current_dir = &getcwd; -if ($Stow) { - chdir($Stow) || die "Cannot chdir to target tree $Stow ($!)\n"; -} - -# This prevents problems if $Target was supplied as a relative path -$Stow = &getcwd; - -chdir($current_dir) || die "Your directory does not seem to exist anymore ($!)\n"; - -$Target = &parent($Stow) unless $Target; - -chdir($Target) || die "Cannot chdir to target tree $Target ($!)\n"; -$Target = &getcwd; - -foreach $package (@ARGV) { - $package =~ s,/+$,,; # delete trailing slashes - if ($package =~ m,/,) { - die "$ProgramName: slashes not permitted in package names\n"; - } -} - -if ($Delete || $Restow) { - @Collections = @ARGV; - &Unstow('', &RelativePath($Target, $Stow)); -} - -if (!$Delete || $Restow) { - foreach $Collection (@ARGV) { - warn "Stowing package $Collection...\n" if $Verbose; - &StowContents($Collection, &RelativePath($Target, $Stow)); - } -} - -sub CommonParent { - local($dir1, $dir2) = @_; - local($result, $x); - local(@d1) = split(/\/+/, $dir1); - local(@d2) = split(/\/+/, $dir2); - - while (@d1 && @d2 && (($x = shift(@d1)) eq shift(@d2))) { - $result .= "$x/"; - } - chop($result); - $result; -} - -# Find the relative patch between -# two paths given as arguments. - -sub RelativePath { - local($a, $b) = @_; - local($c) = &CommonParent($a, $b); - local(@a) = split(/\/+/, $a); - local(@b) = split(/\/+/, $b); - local(@c) = split(/\/+/, $c); - - # if $c == "/something", scalar(@c) >= 2 - # but if $c == "/", scalar(@c) == 0 - # but we want 1 - my $length = scalar(@c) ? scalar(@c) : 1; - splice(@a, 0, $length); - splice(@b, 0, $length); - - unshift(@b, (('..') x (@a + 0))); - &JoinPaths(@b); -} - -# Basically concatenates the paths given -# as arguments - -sub JoinPaths { - local(@paths, @parts); - local ($x, $y); - local($result) = ''; - - $result = '/' if ($_[0] =~ /^\//); - foreach $x (@_) { - @parts = split(/\/+/, $x); - foreach $y (@parts) { - push(@paths, $y) if ($y ne ""); - } - } - $result .= join('/', @paths); -} - -sub Unstow { - local($targetdir, $stow) = @_; - local(@contents); - local($content); - local($linktarget, $stowmember, $collection); - local(@stowmember); - local($pure, $othercollection) = (1, ''); - local($subpure, $subother); - local($empty) = (1); - local(@puresubdirs); - - return (0, '') if (&JoinPaths($Target, $targetdir) eq $Stow); - return (0, '') if (-e &JoinPaths($Target, $targetdir, '.stow')); - warn sprintf("Unstowing in %s\n", &JoinPaths($Target, $targetdir)) - if ($Verbose > 1); - my $dir = &JoinPaths($Target, $targetdir); - if (!opendir(DIR, $dir)) { - warn "Warning: $ProgramName: Cannot read directory \"$dir\" ($!). Stow might leave some links. If you think, it does. Rerun Stow with appropriate rights.\n"; - } - @contents = readdir(DIR); - closedir(DIR); - foreach $content (@contents) { - next if (($content eq '.') || ($content eq '..')); - $empty = 0; - if (-l &JoinPaths($Target, $targetdir, $content)) { - ($linktarget = readlink(&JoinPaths($Target, - $targetdir, - $content))) - || die sprintf("%s: Cannot read link %s (%s)\n", - $ProgramName, - &JoinPaths($Target, $targetdir, $content), - $!); - if ($stowmember = &FindStowMember(&JoinPaths($Target, - $targetdir), - $linktarget)) { - @stowmember = split(/\/+/, $stowmember); - $collection = shift(@stowmember); - if (grep(($collection eq $_), @Collections)) { - &DoUnlink(&JoinPaths($Target, $targetdir, $content)); - } elsif ($pure) { - if ($othercollection) { - $pure = 0 if ($collection ne $othercollection); - } else { - $othercollection = $collection; - } - } - } else { - $pure = 0; - } - } elsif (-d &JoinPaths($Target, $targetdir, $content)) { - ($subpure, $subother) = &Unstow(&JoinPaths($targetdir, $content), - &JoinPaths('..', $stow)); - if ($subpure) { - push(@puresubdirs, "$content/$subother"); - } - if ($pure) { - if ($subpure) { - if ($othercollection) { - if ($subother) { - if ($othercollection ne $subother) { - $pure = 0; - } - } - } elsif ($subother) { - $othercollection = $subother; - } - } else { - $pure = 0; - } - } - } else { - $pure = 0; - } - } - # This directory was an initially empty directory therefore - # We do not remove it. - $pure = 0 if $empty; - if ((!$pure || !$targetdir) && @puresubdirs) { - &CoalesceTrees($targetdir, $stow, @puresubdirs); - } - ($pure, $othercollection); -} - -sub CoalesceTrees { - local($parent, $stow, @trees) = @_; - local($tree, $collection, $x); - - foreach $x (@trees) { - ($tree, $collection) = ($x =~ /^(.*)\/(.*)/); - &EmptyTree(&JoinPaths($Target, $parent, $tree)); - &DoRmdir(&JoinPaths($Target, $parent, $tree)); - if ($collection) { - &DoLink(&JoinPaths($stow, $collection, $parent, $tree), - &JoinPaths($Target, $parent, $tree)); - } - } -} - -sub EmptyTree { - local($dir) = @_; - local(@contents); - local($content); - - opendir(DIR, $dir) - || die "$ProgramName: Cannot read directory \"$dir\" ($!)\n"; - @contents = readdir(DIR); - closedir(DIR); - foreach $content (@contents) { - next if (($content eq '.') || ($content eq '..')); - if (-l &JoinPaths($dir, $content)) { - &DoUnlink(&JoinPaths($dir, $content)); - } elsif (-d &JoinPaths($dir, $content)) { - &EmptyTree(&JoinPaths($dir, $content)); - &DoRmdir(&JoinPaths($dir, $content)); - } else { - &DoUnlink(&JoinPaths($dir, $content)); - } - } -} - -sub StowContents { - local($dir, $stow) = @_; - local(@contents); - local($content); - - warn "Stowing contents of $dir\n" if ($Verbose > 1); - my $joined = &JoinPaths($Stow, $dir); - opendir(DIR, $joined) - || die "$ProgramName: Cannot read directory \"$dir\" ($!)\n"; - @contents = readdir(DIR); - closedir(DIR); - foreach $content (@contents) { - # Wed Nov 23 2005 Adam Spiers - # hack to ignore stuff in ~/.cvsignore - next if $content eq '.' or $content eq '..'; - if ($content =~ $ignore_re) { - # FIXME: We assume -r implies the open succeeded but this is not - # true if we're stowing cvs as .cvsignore only gets created - # halfway through. - warn "Ignoring $joined/$content", (-r $ignore_file ? " via $ignore_file" : ""), "\n" - if $Verbose > 2; - next; - } - if (-d &JoinPaths($Stow, $dir, $content)) { - &StowDir(&JoinPaths($dir, $content), $stow); - } else { - &StowNondir(&JoinPaths($dir, $content), $stow); - } - } -} - -sub StowDir { - local($dir, $stow) = @_; - local(@dir) = split(/\/+/, $dir); - local($collection) = shift(@dir); - local($subdir) = join('/', @dir); - local($linktarget, $stowsubdir); - - warn "Stowing directory $dir\n" if ($Verbose > 1); - if (-l &JoinPaths($Target, $subdir)) { - ($linktarget = readlink(&JoinPaths($Target, $subdir))) - || die sprintf("%s: Could not read link %s (%s)\n", - $ProgramName, - &JoinPaths($Target, $subdir), - $!); - ($stowsubdir = - &FindStowMember(sprintf('%s/%s', $Target, - join('/', @dir[0..($#dir - 1)])), - $linktarget)) - || (&Conflict($dir, $subdir, 1), return); - if (-e &JoinPaths($Stow, $stowsubdir)) { - if ($stowsubdir eq $dir) { - warn sprintf("%s already points to %s\n", - &JoinPaths($Target, $subdir), - &JoinPaths($Stow, $dir)) - if ($Verbose > 2); - return; - } - if (-d &JoinPaths($Stow, $stowsubdir)) { - &DoUnlink(&JoinPaths($Target, $subdir)); - &DoMkdir(&JoinPaths($Target, $subdir)); - &StowContents($stowsubdir, &JoinPaths('..', $stow)); - &StowContents($dir, &JoinPaths('..', $stow)); - } else { - (&Conflict($dir, $subdir, 2), return); - } - } else { - &DoUnlink(&JoinPaths($Target, $subdir)); - &DoLink(&JoinPaths($stow, $dir), - &JoinPaths($Target, $subdir)); - } - } elsif (-e &JoinPaths($Target, $subdir)) { - if (-d &JoinPaths($Target, $subdir)) { - &StowContents($dir, &JoinPaths('..', $stow)); - } else { - &Conflict($dir, $subdir, 3); - } - } else { - &DoLink(&JoinPaths($stow, $dir), - &JoinPaths($Target, $subdir)); - } -} - -sub StowNondir { - local($file, $stow) = @_; - local(@file) = split(/\/+/, $file); - local($collection) = shift(@file); - local($subfile) = join('/', @file); - local($linktarget, $stowsubfile); - - if (-l &JoinPaths($Target, $subfile)) { - ($linktarget = readlink(&JoinPaths($Target, $subfile))) - || die sprintf("%s: Could not read link %s (%s)\n", - $ProgramName, - &JoinPaths($Target, $subfile), - $!); - ($stowsubfile = - &FindStowMember(sprintf('%s/%s', $Target, - join('/', @file[0..($#file - 1)])), - $linktarget)) - || (&Conflict($file, $subfile, 4), return); - if (-e &JoinPaths($Stow, $stowsubfile)) { - (&Conflict($file, $subfile, 5), return) - unless ($stowsubfile eq $file); - warn sprintf("%s already points to %s\n", - &JoinPaths($Target, $subfile), - &JoinPaths($Stow, $file)) - if ($Verbose > 2); - } else { - &DoUnlink(&JoinPaths($Target, $subfile)); - &DoLink(&JoinPaths($stow, $file), - &JoinPaths($Target, $subfile)); - } - } elsif (-e &JoinPaths($Target, $subfile)) { - &Conflict($file, $subfile, 6); - } else { - &DoLink(&JoinPaths($stow, $file), - &JoinPaths($Target, $subfile)); - } -} - -sub DoUnlink { - local($file) = @_; - - warn "UNLINK $file\n" if $Verbose; - (unlink($file) || die "$ProgramName: Could not unlink $file ($!)\n") - unless $NotReally; -} - -sub DoRmdir { - local($dir) = @_; - - warn "RMDIR $dir\n" if $Verbose; - (rmdir($dir) || die "$ProgramName: Could not rmdir $dir ($!)\n") - unless $NotReally; -} - -sub DoLink { - local($target, $name) = @_; - - warn "LINK $name to $target\n" if $Verbose; - (symlink($target, $name) || - die "$ProgramName: Could not symlink $name to $target ($!)\n") - unless $NotReally; -} - -sub DoMkdir { - local($dir) = @_; - - warn "MKDIR $dir\n" if $Verbose; - (mkdir($dir, 0777) - || die "$ProgramName: Could not make directory $dir ($!)\n") - unless $NotReally; -} - -sub Conflict { - local($a, $b, $type) = @_; - - my $src = &JoinPaths($Stow, $a); - my $dst = &JoinPaths($Target, $b); - - if ($Conflicts) { - warn "CONFLICT: $src vs. $dst", ($type ? " ($type)" : ''), "\n"; - #system "ls -l $src $dst"; - } else { - die "$ProgramName: CONFLICT: $src vs. $dst", ($type ? " ($type)" : ''), "\n"; - } -} - -sub FindStowMember { - local($start, $path) = @_; - local(@x) = split(/\/+/, $start); - local(@path) = split(/\/+/, $path); - local($x); - local(@d) = split(/\/+/, $Stow); - - while (@path) { - $x = shift(@path); - if ($x eq '..') { - pop(@x); - return '' unless @x; - } elsif ($x) { - push(@x, $x); - } - } - while (@x && @d) { - if (($x = shift(@x)) ne shift(@d)) { - return ''; - } - } - return '' if @d; - join('/', @x); -} - -sub parent { - local($path) = join('/', @_); - local(@elts) = split(/\/+/, $path); - pop(@elts); - join('/', @elts); -} sub usage { - local($msg) = shift; + my($msg) = shift; if ($msg) { - print "$ProgramName: $msg\n"; + print "$RealScript: $msg\n"; } - print "$ProgramName (GNU Stow) version $Version\n\n"; - print "Usage: $ProgramName [OPTION ...] PACKAGE ...\n"; + print "$RealScript (GNU Stow) version $Version\n\n"; + print "Usage: $RealScript [OPTION ...] PACKAGE ...\n"; print <) { - chomp; - push @regexps, glob_to_re($_); - } - close(REGEXPS); - my $re = join '|', @regexps; - warn "#% ignore regexp is $re\n" if $Verbose; - return qr/$re/; -} - -# Local variables: -# mode: perl -# End: