lib/Stow/Util.pm.in

   1 # This file is part of GNU Stow.
   2 #
   3 # GNU Stow is free software: you can redistribute it and/or modify it
   4 # under the terms of the GNU General Public License as published by
   5 # the Free Software Foundation, either version 3 of the License, or
   6 # (at your option) any later version.
   7 #
   8 # GNU Stow is distributed in the hope that it will be useful, but
   9 # WITHOUT ANY WARRANTY; without even the implied warranty of
  10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  11 # General Public License for more details.
  12 #
  13 # You should have received a copy of the GNU General Public License
  14 # along with this program. If not, see https://www.gnu.org/licenses/.
  15
  16 package Stow::Util;
  17
  18 =head1 NAME
  19
  20 Stow::Util - general utilities
  21
  22 =head1 SYNOPSIS
  23
  24     use Stow::Util qw(debug set_debug_level error ...);
  25
  26 =head1 DESCRIPTION
  27
  28 Supporting utility routines for L<Stow>.
  29
  30 =cut
  31
  32 use strict;
  33 use warnings;
  34
  35 use File::Spec;
  36 use POSIX qw(getcwd);
  37
  38 use base qw(Exporter);
  39 our @EXPORT_OK = qw(
  40     error debug set_debug_level set_test_mode
  41     join_paths parent canon_path restore_cwd adjust_dotfile
  42 );
  43
  44 our $ProgramName = 'stow';
  45 our $VERSION = '@VERSION@';
  46
  47 #############################################################################
  48 #
  49 # General Utilities: nothing stow specific here.
  50 #
  51 #############################################################################
  52
  53 =head1 IMPORTABLE SUBROUTINES
  54
  55 =head2 error($format, @args)
  56
  57 Outputs an error message in a consistent form and then dies.
  58
  59 =cut
  60
  61 sub error {
  62     my ($format, @args) = @_;
  63     die "$ProgramName: ERROR: " . sprintf($format, @args) . "\n";
  64 }
  65
  66 =head2 set_debug_level($level)
  67
  68 Sets verbosity level for C<debug()>.
  69
  70 =cut
  71
  72 our $debug_level = 0;
  73
  74 sub set_debug_level {
  75     my ($level) = @_;
  76     $debug_level = $level;
  77 }
  78
  79 =head2 set_test_mode($on_or_off)
  80
  81 Sets testmode on or off.
  82
  83 =cut
  84
  85 our $test_mode = 0;
  86
  87 sub set_test_mode {
  88     my ($on_or_off) = @_;
  89     if ($on_or_off) {
  90         $test_mode = 1;
  91     }
  92     else {
  93         $test_mode = 0;
  94     }
  95 }
  96
  97 =head2 debug($level[, $indent_level], $msg)
  98
  99 Logs to STDERR based on C<$debug_level> setting.  C<$level> is the
 100 minimum verbosity level required to output C<$msg>.  All output is to
 101 STDERR to preserve backward compatibility, except for in test mode,
 102 when STDOUT is used instead.  In test mode, the verbosity can be
 103 overridden via the C<TEST_VERBOSE> environment variable.
 104
 105 Verbosity rules:
 106
 107 =over 4
 108
 109 =item    0: errors only
 110
 111 =item >= 1: print operations: LINK/UNLINK/MKDIR/RMDIR/MV
 112
 113 =item >= 2: print operation exceptions
 114
 115 e.g. "_this_ already points to _that_", skipping, deferring,
 116 overriding, fixing invalid links
 117
 118 =item >= 3: print trace detail: trace: stow/unstow/package/contents/node
 119
 120 =item >= 4: debug helper routines
 121
 122 =item >= 5: debug ignore lists
 123
 124 =back
 125
 126 =cut
 127
 128 sub debug {
 129     my $level = shift;
 130     my $indent_level;
 131     # Maintain backwards-compatibility in case anyone's relying on this.
 132     $indent_level = $_[0] =~ /^\d+$/ ? shift : 0;
 133     my $msg = shift;
 134     if ($debug_level >= $level) {
 135         my $indent = '    ' x $indent_level;
 136         if ($test_mode) {
 137             print "# $indent$msg\n";
 138         }
 139         else {
 140             warn "$indent$msg\n";
 141         }
 142     }
 143 }
 144
 145 #===== METHOD ===============================================================
 146 # Name      : join_paths()
 147 # Purpose   : concatenates given paths
 148 # Parameters: path1, path2, ... => paths
 149 # Returns   : concatenation of given paths
 150 # Throws    : n/a
 151 # Comments  : Factors out some redundant path elements:
 152 #           : '//' => '/', and 'a/b/../c' => 'a/c'.  We need this function
 153 #           : with this behaviour, even though b could be a symlink to
 154 #           : elsewhere, as noted in the perldoc for File::Spec->canonpath().
 155 #           : This behaviour is deliberately different to
 156 #           : Stow::Util::canon_path(), because the way join_paths() is used
 157 #           : relies on this.  Firstly, there is no guarantee that the paths
 158 #           : exist, so a filesystem check is inappropriate.
 159 #           :
 160 #           : For example, it's used to determine the path from the target
 161 #           : directory to a symlink destination.  So if a symlink
 162 #           : path/to/target/a/b/c points to ../../../stow/pkg/a/b/c,
 163 #           : then joining path/to/target/a/b with ../../../stow/pkg/a/b/c
 164 #           : yields path/to/stow/pkg/a/b/c, and it's crucial that the
 165 #           : path/to/stow prefix matches a recognisable stow directory.
 166 #============================================================================
 167 sub join_paths {
 168     my @paths = @_;
 169
 170     debug(5, 5, "| Joining: @paths");
 171     my $result = '';
 172     for my $part (@paths) {
 173         next if ! length $part;  # probably shouldn't happen?
 174         $part = File::Spec->canonpath($part);
 175
 176         if (substr($part, 0, 1) eq '/') {
 177             $result = $part; # absolute path, so ignore all previous parts
 178         }
 179         else {
 180             $result .= '/' if length $result && $result ne '/';
 181             $result .= $part;
 182         }
 183         debug(7, 6, "| Join now: $result");
 184     }
 185     debug(6, 5, "| Joined: $result");
 186
 187     # Need this to remove any initial ./
 188     $result = File::Spec->canonpath($result);
 189
 190     # remove foo/..
 191     1 while $result =~ s,(^|/)(?!\.\.)[^/]+/\.\.(/|$),$1,;
 192     debug(6, 5, "| After .. removal: $result");
 193
 194     $result = File::Spec->canonpath($result);
 195     debug(5, 5, "| Final join: $result");
 196
 197     return $result;
 198 }
 199
 200 #===== METHOD ===============================================================
 201 # Name      : parent
 202 # Purpose   : find the parent of the given path
 203 # Parameters: @path => components of the path
 204 # Returns   : returns a path string
 205 # Throws    : n/a
 206 # Comments  : allows you to send multiple chunks of the path
 207 #           : (this feature is currently not used)
 208 #============================================================================
 209 sub parent {
 210     my @path = @_;
 211     my $path = join '/', @_;
 212     my @elts = split m{/+}, $path;
 213     pop @elts;
 214     return join '/', @elts;
 215 }
 216
 217 #===== METHOD ===============================================================
 218 # Name      : canon_path
 219 # Purpose   : find absolute canonical path of given path
 220 # Parameters: $path
 221 # Returns   : absolute canonical path
 222 # Throws    : n/a
 223 # Comments  : is this significantly different from File::Spec->rel2abs?
 224 #============================================================================
 225 sub canon_path {
 226     my ($path) = @_;
 227
 228     my $cwd = getcwd();
 229     chdir($path) or error("canon_path: cannot chdir to $path from $cwd");
 230     my $canon_path = getcwd();
 231     restore_cwd($cwd);
 232
 233     return $canon_path;
 234 }
 235
 236 sub restore_cwd {
 237     my ($prev) = @_;
 238     chdir($prev) or error("Your current directory $prev seems to have vanished");
 239 }
 240
 241 sub adjust_dotfile {
 242     my ($pkg_node) = @_;
 243     (my $adjusted = $pkg_node) =~ s/^dot-([^.])/.$1/;
 244     return $adjusted;
 245 }
 246
 247 =head1 BUGS
 248
 249 =head1 SEE ALSO
 250
 251 =cut
 252
 253 1;
 254
 255 # Local variables:
 256 # mode: perl
 257 # end:
 258 # vim: ft=perl