| 1 | package Psh::OS; |
| 2 | |
| 3 | use strict; |
| 4 | |
| 5 | my $ospackage; |
| 6 | |
| 7 | BEGIN { |
| 8 | if ($^O eq 'MSWin32') { |
| 9 | $ospackage='Psh::OS::Win'; |
| 10 | require Psh::OS::Win; |
| 11 | die "Could not find OS specific package $ospackage: $@" if $@; |
| 12 | } else { |
| 13 | $ospackage='Psh::OS::Unix'; |
| 14 | require Psh::OS::Unix; |
| 15 | die "Could not find OS specific package $ospackage: $@" if $@; |
| 16 | } |
| 17 | } |
| 18 | |
| 19 | sub AUTOLOAD { |
| 20 | no strict; |
| 21 | $AUTOLOAD=~ s/.*:://; |
| 22 | my $name="${ospackage}::$AUTOLOAD"; |
| 23 | $name="Psh::OS::fb_$AUTOLOAD" unless ref *{$name}{CODE} eq 'CODE'; |
| 24 | unless (ref *{$name}{CODE} eq 'CODE') { |
| 25 | require Carp; |
| 26 | eval { |
| 27 | Carp::croak("Function `$AUTOLOAD' in Psh::OS does not exist."); |
| 28 | }; |
| 29 | } |
| 30 | *$AUTOLOAD= *$name; |
| 31 | goto &$AUTOLOAD; |
| 32 | } |
| 33 | |
| 34 | # |
| 35 | # The following code is here because it is most probably |
| 36 | # portable across at least a large number of platforms |
| 37 | # If you need to override them, then modify the symbol |
| 38 | # table :-) |
| 39 | |
| 40 | # recursive glob function used for **/anything glob |
| 41 | sub _recursive_glob { |
| 42 | my( $pattern, $dir)= @_; |
| 43 | opendir( DIR, $dir) || return (); |
| 44 | my @files= readdir(DIR); |
| 45 | closedir( DIR); |
| 46 | my @result= map { catdir($dir,$_) } |
| 47 | grep { /^$pattern$/ } @files; |
| 48 | foreach my $tmp (@files) { |
| 49 | my $tmpdir= catdir($dir,$tmp); |
| 50 | next if ! -d $tmpdir || !no_upwards($tmp); |
| 51 | push @result, _recursive_glob($pattern, $tmpdir); |
| 52 | } |
| 53 | return @result; |
| 54 | } |
| 55 | |
| 56 | sub _escape { |
| 57 | my $text= shift; |
| 58 | if ($] >= 5.005) { |
| 59 | $text=~s/(?<!\\)([^a-zA-Z0-9\*\?])/\\$1/g; |
| 60 | } else { |
| 61 | # TODO: no escaping yet |
| 62 | } |
| 63 | return $text; |
| 64 | } |
| 65 | |
| 66 | # |
| 67 | # The Perl builtin glob STILL uses csh, furthermore it is |
| 68 | # not possible to supply a base directory... so I guess this |
| 69 | # is faster |
| 70 | # |
| 71 | sub fb_glob { |
| 72 | my( $pattern, $dir, $already_absed) = @_; |
| 73 | |
| 74 | return () unless $pattern; |
| 75 | |
| 76 | my @result; |
| 77 | if( !$dir) { |
| 78 | $dir=$ENV{PWD}; |
| 79 | } else { |
| 80 | $dir=Psh::Util::abs_path($dir) unless $already_absed; |
| 81 | } |
| 82 | return unless $dir; |
| 83 | |
| 84 | # Expand ~ |
| 85 | my $home= $ENV{HOME}||get_home_dir(); |
| 86 | if ($pattern eq '~') { |
| 87 | $pattern=$home; |
| 88 | } else { |
| 89 | $pattern=~ s|^\~/|$home/|; |
| 90 | $pattern=~ s|^\~([^/]+)|&get_home_dir($1)|e; |
| 91 | } |
| 92 | |
| 93 | return $pattern if $pattern !~ /[*?]/; |
| 94 | |
| 95 | # Special recursion handling for **/anything globs |
| 96 | if( $pattern=~ m:^([^\*]+/)?\*\*/(.*)$: ) { |
| 97 | my $tlen= length($dir)+1; |
| 98 | my $prefix= $1||''; |
| 99 | $pattern= $2; |
| 100 | $prefix=~ s:/$::; |
| 101 | $dir= catdir($dir,$prefix); |
| 102 | $pattern=_escape($pattern); |
| 103 | $pattern=~s/\*/[^\/]*/g; |
| 104 | $pattern=~s/\?/./g; |
| 105 | $pattern='[^\.]'.$pattern if( substr($pattern,0,2) eq '.*'); |
| 106 | @result= map { substr($_,$tlen) } _recursive_glob($pattern,$dir); |
| 107 | } elsif( $pattern=~ m:/:) { |
| 108 | # Too difficult to simulate, so use slow variant |
| 109 | my $old=$ENV{PWD}; |
| 110 | CORE::chdir $dir; |
| 111 | $pattern=_escape($pattern); |
| 112 | @result= eval { CORE::glob($pattern); }; |
| 113 | CORE::chdir $old; |
| 114 | } else { |
| 115 | # The fast variant for simple matches |
| 116 | $pattern=_escape($pattern); |
| 117 | $pattern=~s/\*/.*/g; |
| 118 | $pattern=~s/\?/./g; |
| 119 | $pattern='[^\.]'.$pattern if( substr($pattern,0,2) eq '.*'); |
| 120 | |
| 121 | opendir( DIR, $dir) || return (); |
| 122 | @result= grep { /^$pattern$/ } readdir(DIR); |
| 123 | closedir( DIR); |
| 124 | } |
| 125 | return @result; |
| 126 | } |
| 127 | |
| 128 | # |
| 129 | # string signal_name( int ) |
| 130 | # Looks up the name of a signal |
| 131 | # |
| 132 | |
| 133 | sub fb_signal_name { |
| 134 | my $signalnum = shift; |
| 135 | require Config; |
| 136 | my @numbers= split ',',$Config::Config{sig_num}; |
| 137 | @numbers= split ' ',$Config::Config{sig_num} if( @numbers==1); |
| 138 | # Strange incompatibility between perl versions |
| 139 | |
| 140 | my @names= split ' ',$Config::Config{sig_name}; |
| 141 | for( my $i=0; $i<$#numbers; $i++) |
| 142 | { |
| 143 | return $names[$i] if( $numbers[$i]==$signalnum); |
| 144 | } |
| 145 | return $signalnum; |
| 146 | } |
| 147 | |
| 148 | # |
| 149 | # string signal_description( int signal_number | string signal_name ) |
| 150 | # returns a descriptive name for the POSIX signals |
| 151 | # |
| 152 | |
| 153 | sub fb_signal_description { |
| 154 | my $signal_name= signal_name(shift); |
| 155 | my $desc= Psh::Locale::get_text('sig_description')->{$signal_name}; |
| 156 | if( defined($desc) and $desc) { |
| 157 | return "SIG$signal_name - $desc"; |
| 158 | } |
| 159 | return "signal $signal_name"; |
| 160 | } |
| 161 | |
| 162 | # Return a name for a temp file |
| 163 | |
| 164 | sub fb_tmpnam { |
| 165 | return POSIX::tmpnam(); |
| 166 | } |
| 167 | |
| 168 | sub fb_get_window_size {} |
| 169 | sub fb_remove_signal_handlers {1} |
| 170 | sub fb_setup_signal_handlers {1} |
| 171 | sub fb_setup_sigsegv_handler {1} |
| 172 | sub fb_setup_readline_handler {1} |
| 173 | sub fb_reap_children {1} |
| 174 | sub fb_abs_path { undef } |
| 175 | |
| 176 | # |
| 177 | # Exit psh - you won't believe it, but exit needs special treatment on |
| 178 | # MacOS |
| 179 | # |
| 180 | sub fb_exit_psh { |
| 181 | Psh::Util::print_debug_class('i',"[Psh::OS::exit_psh() called]\n"); |
| 182 | Psh::save_history(); |
| 183 | $ENV{SHELL} = $Psh::old_shell if $Psh::old_shell; |
| 184 | CORE::exit($_[0]) if $_[0]; |
| 185 | CORE::exit(0); |
| 186 | } |
| 187 | |
| 188 | sub fb_getcwd_psh { |
| 189 | eval { require Cwd; }; |
| 190 | return eval { Cwd::getcwd(); } || ''; |
| 191 | } |
| 192 | |
| 193 | sub fb_LOCK_SH() { 1; } |
| 194 | sub fb_LOCK_EX() { 2; } |
| 195 | sub fb_LOCK_NB() { 4; } |
| 196 | sub fb_LOCK_UN() { 8; } |
| 197 | |
| 198 | sub fb_lock { |
| 199 | my $file= shift; |
| 200 | my $type= shift || Psh::OS::LOCK_SH(); |
| 201 | my $count=3; |
| 202 | my $status=0; |
| 203 | while ($count-- and !$status) { |
| 204 | $status= flock($file, $type| Psh::OS::LOCK_NB()); |
| 205 | } |
| 206 | return $status; |
| 207 | } |
| 208 | |
| 209 | sub fb_unlock { |
| 210 | my $file= shift; |
| 211 | flock($file, Psh::OS::LOCK_UN()| Psh::OS::LOCK_NB()); |
| 212 | } |
| 213 | |
| 214 | sub fb_reinstall_resize_handler { 1; } |
| 215 | |
| 216 | { |
| 217 | my $handler_type=0; |
| 218 | |
| 219 | sub fb_install_resize_handler { |
| 220 | eval '$Psh::term->get_screen_size()'; |
| 221 | unless ($@) { |
| 222 | $handler_type=3; |
| 223 | return; |
| 224 | } |
| 225 | eval 'use Term::Size;'; |
| 226 | if ($@) { |
| 227 | eval 'use Term::ReadKey;'; |
| 228 | unless ($@) { |
| 229 | $handler_type=2; |
| 230 | } |
| 231 | } else { |
| 232 | $handler_type=1; |
| 233 | } |
| 234 | } |
| 235 | |
| 236 | |
| 237 | sub fb_check_terminal_size { |
| 238 | my ($cols,$rows); |
| 239 | |
| 240 | if ($handler_type==0) { |
| 241 | return; |
| 242 | } elsif ($handler_type==3) { |
| 243 | eval { |
| 244 | ($rows,$cols)= $Psh::term->get_screen_size(); |
| 245 | }; |
| 246 | } elsif ($handler_type==1) { |
| 247 | eval { |
| 248 | ($cols,$rows)= Term::Size::chars(); |
| 249 | }; |
| 250 | } elsif ($handler_type==2) { |
| 251 | eval { |
| 252 | ($cols,$rows)= Term::ReadKey::GetTerminalSize(*STDOUT); |
| 253 | }; |
| 254 | } |
| 255 | |
| 256 | if($cols && $rows && ($cols > 0) && ($rows > 0)) { |
| 257 | $ENV{COLUMNS} = $cols; |
| 258 | $ENV{LINES} = $rows; |
| 259 | if( $Psh::term) { |
| 260 | $Psh::term->Attribs->{screen_width}=$cols-1; |
| 261 | } |
| 262 | # for ReadLine::Perl |
| 263 | } |
| 264 | } |
| 265 | } |
| 266 | |
| 267 | |
| 268 | # File::Spec |
| 269 | # |
| 270 | # We add the necessary functions directly because: |
| 271 | # 1) Changes to File::Spec might be fatal to psh's file location mechanisms |
| 272 | # 2) File::Spec loads unwanted modules |
| 273 | # 3) We don't need it anyway as we need platform-specific OS modules |
| 274 | # anyway |
| 275 | # |
| 276 | # Normally I wouldn't do it - but this is a shell and memory |
| 277 | # consumption and startup time is worth something for everyday work... |
| 278 | |
| 279 | sub fb_no_upwards { |
| 280 | return grep(!/^\.{1,2}\Z(?!\n)/s, @_); |
| 281 | } |
| 282 | |
| 283 | |
| 284 | 1; |
| 285 | |
| 286 | __END__ |
| 287 | |
| 288 | =head1 NAME |
| 289 | |
| 290 | Psh::OS - Wrapper class for OS dependant stuff |
| 291 | |
| 292 | |
| 293 | =head1 SYNOPSIS |
| 294 | |
| 295 | use Psh::OS; |
| 296 | |
| 297 | =head1 DESCRIPTION |
| 298 | |
| 299 | TBD |
| 300 | |
| 301 | =head1 AUTHOR |
| 302 | |
| 303 | Markus Peter, warp@spin.de |
| 304 | |
| 305 | =head1 SEE ALSO |
| 306 | |
| 307 | =cut |
| 308 | |
| 309 | # The following is for Emacs - I hope it won't annoy anyone |
| 310 | # but this could solve the problems with different tab widths etc |
| 311 | # |
| 312 | # Local Variables: |
| 313 | # tab-width:4 |
| 314 | # indent-tabs-mode:t |
| 315 | # c-basic-offset:4 |
| 316 | # perl-indent-level:4 |
| 317 | # End: |
| 318 | |
| 319 | |