| 1 | package Psh::Util; |
| 2 | |
| 3 | use strict; |
| 4 | |
| 5 | require Psh::OS; |
| 6 | |
| 7 | %Psh::Util::command_hash=(); |
| 8 | %Psh::Util::path_hash=(); |
| 9 | |
| 10 | sub print_warning |
| 11 | { |
| 12 | print STDERR @_; |
| 13 | } |
| 14 | |
| 15 | # |
| 16 | # Print unclassified debug output |
| 17 | # |
| 18 | sub print_debug |
| 19 | { |
| 20 | print STDERR @_ if $Psh::debugging && $Psh::debugging =~ /o/; |
| 21 | } |
| 22 | |
| 23 | # |
| 24 | # Print classified debug output |
| 25 | # |
| 26 | sub print_debug_class |
| 27 | { |
| 28 | my $class= shift; |
| 29 | print STDERR @_ if $Psh::debugging and |
| 30 | ($Psh::debugging eq '1' or |
| 31 | $Psh::debugging =~ /$class/); |
| 32 | } |
| 33 | |
| 34 | sub print_error |
| 35 | { |
| 36 | print STDERR @_; |
| 37 | } |
| 38 | |
| 39 | # |
| 40 | # print_i18n( stream, key, args) |
| 41 | # print_out_i18n( key, args) |
| 42 | # print_error_i18n( key, args) |
| 43 | # |
| 44 | # The print..._i18n suite of functions will fetch the |
| 45 | # text from the %text hash, replace %1 with the first arg, |
| 46 | # %2 with the second and so on and then print it out |
| 47 | # |
| 48 | |
| 49 | sub _print_i18n |
| 50 | { |
| 51 | my( $stream, $text, @rest) = @_; |
| 52 | return unless $stream; |
| 53 | $text= Psh::Locale::get_text($text); |
| 54 | for( my $i=1; $i<=@rest; $i++) |
| 55 | { |
| 56 | $text=~ s/\%$i/$rest[$i-1]/g; |
| 57 | } |
| 58 | print $stream $text; |
| 59 | } |
| 60 | |
| 61 | |
| 62 | sub print_error_i18n |
| 63 | { |
| 64 | _print_i18n(*STDERR,@_); |
| 65 | } |
| 66 | |
| 67 | sub print_warning_i18n |
| 68 | { |
| 69 | _print_i18n(*STDERR,@_); |
| 70 | } |
| 71 | |
| 72 | sub print_out_i18n |
| 73 | { |
| 74 | _print_i18n(*STDOUT,@_); |
| 75 | } |
| 76 | |
| 77 | sub print_out |
| 78 | { |
| 79 | print STDOUT @_; |
| 80 | } |
| 81 | |
| 82 | # Copied from readline.pl - pretty prints a list in columns |
| 83 | sub print_list |
| 84 | { |
| 85 | my @list= @_; |
| 86 | return unless @list; |
| 87 | my ($lines, $columns, $mark, $index); |
| 88 | |
| 89 | ## find width of widest entry |
| 90 | my $maxwidth = 0; |
| 91 | my $screen_width=$ENV{COLUMNS}; |
| 92 | |
| 93 | if (ref $list[0] and ref $list[0] eq 'ARRAY') { |
| 94 | $maxwidth= $list[1]; |
| 95 | @list= @{$list[0]}; |
| 96 | } |
| 97 | |
| 98 | unless ($maxwidth) { |
| 99 | grep(length > $maxwidth && ($maxwidth = length), @list); |
| 100 | } |
| 101 | $maxwidth++; |
| 102 | |
| 103 | $columns = $maxwidth >= $screen_width?1:int($screen_width / $maxwidth); |
| 104 | |
| 105 | ## if there's enough margin to interspurse among the columns, do so. |
| 106 | $maxwidth += int(($screen_width % $maxwidth) / $columns); |
| 107 | |
| 108 | $lines = int((@list + $columns - 1) / $columns); |
| 109 | $columns-- while ((($lines * $columns) - @list + 1) > $lines); |
| 110 | |
| 111 | $mark = $#list - $lines; |
| 112 | for (my $l = 0; $l < $lines; $l++) { |
| 113 | for ($index = $l; $index <= $mark; $index += $lines) { |
| 114 | my $tmp= my $item= $list[$index]; |
| 115 | $tmp=~ s/\001(.*?)\002//g; |
| 116 | $item=~s/\001//g; |
| 117 | $item=~s/\002//g; |
| 118 | my $diff= length($item)-length($tmp); |
| 119 | my $dispsize= $maxwidth+$diff; |
| 120 | print_out(sprintf("%-${dispsize}s", $item)); |
| 121 | } |
| 122 | if ($index<=$#list) { |
| 123 | my $item= $list[$index]; |
| 124 | $item=~s/\001//g; $item=~s/\002//g; |
| 125 | print_out($item); |
| 126 | } |
| 127 | print_out("\n"); |
| 128 | } |
| 129 | } |
| 130 | |
| 131 | sub abs_path { |
| 132 | my $dir= shift; |
| 133 | return undef unless $dir; |
| 134 | return $Psh::Util::path_hash{$dir} if $Psh::Util::path_hash{$dir}; |
| 135 | my $result= Psh::OS::abs_path($dir); |
| 136 | unless ($result) { |
| 137 | if ($dir eq '~') { |
| 138 | $result= Psh::OS::get_home_dir(); |
| 139 | } elsif ( substr($dir,0,2) eq '~/') { |
| 140 | substr($dir,0,1)= Psh::OS::get_home_dir(); |
| 141 | } elsif ( substr($dir,0,1) eq '~' ) { |
| 142 | my $fs= $Psh::OS::FILE_SEPARATOR; |
| 143 | my ($user)= $dir=~/^\~(.*?)$fs/; |
| 144 | if ($user) { |
| 145 | substr($dir,0,length($user)+1)= Psh::OS::get_home_dir($user); |
| 146 | } |
| 147 | } |
| 148 | unless ($result) { |
| 149 | my $tmp= Psh::OS::rel2abs($dir,$ENV{PWD}); |
| 150 | |
| 151 | my $old= $ENV{PWD}; |
| 152 | if ($tmp and -r $tmp) { |
| 153 | if (-d $tmp and -x _) { |
| 154 | if ( CORE::chdir($tmp)) { |
| 155 | $result = Psh::OS::getcwd_psh(); |
| 156 | if (!CORE::chdir($old)) { |
| 157 | print STDERR "Could not change directory back to $old!\n"; |
| 158 | CORE::chdir(Psh::OS::get_home_dir()) |
| 159 | } |
| 160 | } |
| 161 | } else { |
| 162 | $result= $tmp; |
| 163 | } |
| 164 | } |
| 165 | # if ($tmp and !$result) { |
| 166 | # local $^W=0; |
| 167 | # local $SIG{__WARN__}= {}; |
| 168 | # eval { |
| 169 | # $result= Cwd::abs_path($tmp); |
| 170 | # }; |
| 171 | # print_debug_class('e',"(abs_path) Error: $@") if $@; |
| 172 | # } |
| 173 | return undef unless $result; |
| 174 | } |
| 175 | if ($result) { |
| 176 | $result.='/' unless $result=~ m:[/\\]:; # abs_path strips / from letter: on Win |
| 177 | } |
| 178 | } |
| 179 | $Psh::Util::path_hash{$dir}= $result if Psh::OS::file_name_is_absolute($dir); |
| 180 | return $result; |
| 181 | } |
| 182 | |
| 183 | sub recalc_absed_path { |
| 184 | @Psh::absed_path = (); |
| 185 | %Psh::Util::command_hash = (); |
| 186 | |
| 187 | my @path = split($Psh::OS::PATH_SEPARATOR, $ENV{PATH}); |
| 188 | |
| 189 | eval { |
| 190 | foreach my $dir (@path) { |
| 191 | next unless $dir; |
| 192 | my $dir= Psh::Util::abs_path($dir); |
| 193 | next unless -r $dir and -x _; |
| 194 | push @Psh::absed_path, $dir; |
| 195 | } |
| 196 | }; |
| 197 | print_debug_class('e',"(recalc_absed_path) Error: $@") if $@; |
| 198 | # Without the eval Psh might crash if the directory |
| 199 | # does not exist |
| 200 | } |
| 201 | |
| 202 | # |
| 203 | # string which(string FILENAME) |
| 204 | # |
| 205 | # search for an occurrence of FILENAME in the current path as given by |
| 206 | # $ENV{PATH}. Return the absolute filename if found, or undef if not. |
| 207 | # |
| 208 | |
| 209 | { |
| 210 | # |
| 211 | # "static variables" for which() : |
| 212 | # |
| 213 | |
| 214 | my $last_path_cwd = ''; |
| 215 | my $FS=$Psh::OS::FILE_SEPARATOR; |
| 216 | my $tmp= quotemeta($FS); |
| 217 | my $re1="$tmp"; |
| 218 | my $re2="^(.*)$tmp([^$tmp]+)\$"; |
| 219 | |
| 220 | if ($]>=5.005) { |
| 221 | eval { |
| 222 | $re1= qr{$re1}o; |
| 223 | $re2= qr{$re2}o; |
| 224 | }; |
| 225 | print_debug_class('e',"(util::before which) Error: $@") if $@; |
| 226 | } |
| 227 | |
| 228 | sub which |
| 229 | { |
| 230 | my $cmd= shift; |
| 231 | my $all= shift; |
| 232 | return undef unless $cmd; |
| 233 | |
| 234 | |
| 235 | if ($cmd =~ m|$re1|o ) { |
| 236 | $cmd =~ m|$re2|o; |
| 237 | my $path_element= $1 || ''; |
| 238 | my $cmd_element= $2 || ''; |
| 239 | return undef unless $path_element and $cmd_element; |
| 240 | $path_element=Psh::Util::abs_path($path_element); |
| 241 | return undef unless $path_element; |
| 242 | my $try= Psh::OS::catfile($path_element,$cmd_element); |
| 243 | if ((-x $try) and (! -d _)) { return $try; } |
| 244 | return undef; |
| 245 | } |
| 246 | |
| 247 | return $Psh::Util::command_hash{$cmd} if exists $Psh::Util::command_hash{$cmd} and !$all; |
| 248 | |
| 249 | if ($cmd !~ m/$Psh::which_regexp/) { return undef; } |
| 250 | |
| 251 | if ($last_path_cwd ne ($ENV{PATH} . $ENV{PWD})) { |
| 252 | $last_path_cwd = $ENV{PATH} . $ENV{PWD}; |
| 253 | |
| 254 | recalc_absed_path(); |
| 255 | } |
| 256 | |
| 257 | my @path_extension=Psh::OS::get_path_extension(); |
| 258 | my @all=(); |
| 259 | |
| 260 | foreach my $dir (@Psh::absed_path) { |
| 261 | next unless $dir; |
| 262 | my $try = Psh::OS::catfile($dir,$cmd); |
| 263 | foreach my $ext (@path_extension) { |
| 264 | if ((-x $try.$ext) and (!-d _)) { |
| 265 | $Psh::Util::command_hash{$cmd} = $try.$ext unless $all; |
| 266 | return $try.$ext unless $all; |
| 267 | push @all, $try.$ext; |
| 268 | } |
| 269 | } |
| 270 | } |
| 271 | if ($all and @all) { |
| 272 | return @all; |
| 273 | } |
| 274 | $Psh::Util::command_hash{$cmd} = undef; # no delete by purpose |
| 275 | |
| 276 | return undef; |
| 277 | } |
| 278 | } |
| 279 | |
| 280 | # |
| 281 | # starts_with( text, prefix) |
| 282 | # Returns true if text starts with prefix |
| 283 | # |
| 284 | |
| 285 | sub starts_with { |
| 286 | my ($text, $prefix) = @_; |
| 287 | |
| 288 | return length($text)>=length($prefix) && |
| 289 | substr($text,0,length($prefix)) eq $prefix; |
| 290 | } |
| 291 | |
| 292 | # |
| 293 | # ends_with( text, suffix) |
| 294 | # Returns true if text ends with suffix |
| 295 | # |
| 296 | |
| 297 | sub ends_with { |
| 298 | my ( $text, $suffix) = @_; |
| 299 | |
| 300 | return length($text)>=length($suffix) && |
| 301 | substr($text,-length($suffix)) eq $suffix; |
| 302 | } |
| 303 | |
| 304 | # |
| 305 | # list parse_hosts_file( text) |
| 306 | # |
| 307 | # Gets a standard hosts file as input and returns |
| 308 | # a list of the hostnames mentioned in the file |
| 309 | # |
| 310 | sub parse_hosts_file { |
| 311 | my $text= shift; |
| 312 | my @lines= split( /\n|\r|\r\n/, $text); |
| 313 | my @result= (); |
| 314 | foreach my $line (@lines) { |
| 315 | next if $line=~/^\s*$/; # Skip blank lines |
| 316 | next if $line=~/^\s*\#/; # Skip comment lines |
| 317 | $line=~/^\s*\S+\s(.*)$/; |
| 318 | my $rest= $1; |
| 319 | push @result, grep { length($_)>0 } split( /\s/, $rest); |
| 320 | } |
| 321 | return @result; |
| 322 | } |
| 323 | |
| 324 | # |
| 325 | # char prompt( string allowedchars, string prompt) |
| 326 | # prompts the user until he answers with one of the |
| 327 | # allowed characters |
| 328 | # |
| 329 | sub prompt { |
| 330 | my $allowed= shift; |
| 331 | $allowed= "^[$allowed]\$"; |
| 332 | my $text= shift; |
| 333 | my $line=''; |
| 334 | |
| 335 | do { |
| 336 | print $text; |
| 337 | $line=<STDIN>; |
| 338 | } while (!$line || lc($line) !~ $allowed); |
| 339 | chomp $line; |
| 340 | return lc($line); |
| 341 | } |
| 342 | |
| 343 | |
| 344 | 1; |
| 345 | |
| 346 | __END__ |
| 347 | |