| 1 | package Psh::OS::Win; |
| 2 | |
| 3 | use strict; |
| 4 | require Psh::Util; |
| 5 | |
| 6 | eval { |
| 7 | use Win32; |
| 8 | use Win32::TieRegistry 0.20; |
| 9 | use Win32::Process; |
| 10 | use Win32::Console; |
| 11 | use Win32::NetAdmin; |
| 12 | }; |
| 13 | |
| 14 | if ($@) { |
| 15 | Psh::Util::print_error_i18n('no_libwin32'); |
| 16 | die "\n"; |
| 17 | } |
| 18 | |
| 19 | my $console= new Win32::Console(); |
| 20 | my @user_cache=(); |
| 21 | |
| 22 | # |
| 23 | # For documentation see Psh::OS::Unix |
| 24 | # |
| 25 | |
| 26 | $Psh::OS::PATH_SEPARATOR=';'; |
| 27 | $Psh::OS::FILE_SEPARATOR='\\'; |
| 28 | |
| 29 | $Psh::history_file = "psh_history"; |
| 30 | |
| 31 | sub set_window_title { |
| 32 | my $title=shift; |
| 33 | $console->Title($title); |
| 34 | } |
| 35 | |
| 36 | |
| 37 | sub reinstall_resize_handler { |
| 38 | # actually we have no 'handlers' here but instead simply do it |
| 39 | my ($cols,$rows)=$console->Size(); |
| 40 | $ENV{COLUMNS}=$cols; |
| 41 | $ENV{ROWS}=$rows; |
| 42 | } |
| 43 | |
| 44 | sub get_hostname { |
| 45 | my $name_from_reg = $Registry->{"HKEY_LOCAL_MACHINE\\System\\CurrentControlSet\\Control\\ComputerName\\ComputerName\\ComputerName"}; |
| 46 | return $name_from_reg if $name_from_reg; |
| 47 | return 'localhost'; |
| 48 | } |
| 49 | |
| 50 | sub get_known_hosts { |
| 51 | my $hosts_file = "$ENV{windir}\\HOSTS"; |
| 52 | if (open(F_KNOWNHOST,"< $hosts_file")) { |
| 53 | my $hosts_text = join('', <F_KNOWNHOST>); |
| 54 | close(F_KNOWNHOST); |
| 55 | return Psh::Util::parse_hosts_file($hosts_text); |
| 56 | } else { |
| 57 | return ("localhost"); |
| 58 | } |
| 59 | } |
| 60 | |
| 61 | # |
| 62 | # void display_pod(text) |
| 63 | # |
| 64 | sub display_pod { |
| 65 | my $tmp= Psh::OS::tmpnam(); |
| 66 | my $text= shift; |
| 67 | |
| 68 | open( TMP,">$tmp"); |
| 69 | print TMP $text; |
| 70 | close(TMP); |
| 71 | |
| 72 | eval { |
| 73 | require Pod::Text; |
| 74 | Pod::Text::pod2text($tmp,*STDOUT); |
| 75 | }; |
| 76 | print $text if $@; |
| 77 | |
| 78 | unlink($tmp); |
| 79 | } |
| 80 | |
| 81 | sub inc_shlvl { |
| 82 | if (! $ENV{SHLVL}) { |
| 83 | $Psh::login_shell = 1; |
| 84 | $ENV{SHLVL} = 1; |
| 85 | } else { |
| 86 | $Psh::login_shell = 0; |
| 87 | $ENV{SHLVL}++; |
| 88 | } |
| 89 | } |
| 90 | |
| 91 | sub execute_complex_command { |
| 92 | my @array= @{shift()}; |
| 93 | my $fgflag= shift @array; |
| 94 | my @return_val; |
| 95 | my $pgrp_leader=0; |
| 96 | my $success= 0; |
| 97 | my $pid; |
| 98 | my $string=''; |
| 99 | my @tmp; |
| 100 | |
| 101 | if($#array) { |
| 102 | Psh::Util::print_error("No piping yet.\n"); |
| 103 | return (); |
| 104 | } |
| 105 | |
| 106 | my $obj; |
| 107 | for( my $i=0; $i<@array; $i++) { |
| 108 | my ($strategy, $how, $options, $words, $text, $opt)= @{$array[$i]}; |
| 109 | local $Psh::current_options=$opt; |
| 110 | my $line= join(' ',@$words); |
| 111 | my ($eval_thingie,$bgflag); |
| 112 | ($success,$eval_thingie,$words,$bgflag,@return_val)= $strategy->execute( \$line, $words, $how, 0); |
| 113 | |
| 114 | my @tmp; |
| 115 | |
| 116 | if( defined($eval_thingie)) { |
| 117 | ($obj,$success,@tmp)= _fork_process($eval_thingie,$fgflag,$text,undef,$words); |
| 118 | } |
| 119 | if( @return_val < 1 || |
| 120 | !defined($return_val[0])) { |
| 121 | @return_val= @tmp; |
| 122 | } |
| 123 | $string=$text; |
| 124 | } |
| 125 | if ($obj) { |
| 126 | my $pid=$obj->GetProcessID(); |
| 127 | my $job=Psh::Joblist::create_job($pid,$string,$obj); |
| 128 | if( $fgflag) { |
| 129 | _wait_for_system($obj, 1); |
| 130 | } else { |
| 131 | my $visindex= Psh::Joblist::get_job_number($pid); |
| 132 | Psh::Util::print_out("[$visindex] Background $pid $string\n"); |
| 133 | } |
| 134 | } |
| 135 | return ($success,@return_val); |
| 136 | } |
| 137 | |
| 138 | sub _fork_process { |
| 139 | local( $Psh::code, $Psh::fgflag, $Psh::string, $Psh::options, |
| 140 | $Psh::words) = @_; |
| 141 | local $Psh::pid; |
| 142 | |
| 143 | # TODO: perhaps we should use Win32::Process? |
| 144 | # hmm - won't help alot :-( - warp |
| 145 | # print_error_i18n('no_jobcontrol') unless $Psh::fgflag; |
| 146 | |
| 147 | if( ref($Psh::code) eq 'CODE') { |
| 148 | return (0,&{$Psh::code}); |
| 149 | } else { |
| 150 | if ($Psh::words) { |
| 151 | my $obj; |
| 152 | Win32::Process::Create($obj, |
| 153 | @$Psh::words->[0], |
| 154 | $Psh::string, |
| 155 | 0, |
| 156 | NORMAL_PRIORITY_CLASS, |
| 157 | "."); |
| 158 | return ($obj,0); |
| 159 | # We are passing around objects instead of pid because |
| 160 | # Win32::Process currently only allows me to create objects, |
| 161 | # not look them up via pid |
| 162 | } else { |
| 163 | return (0,system($Psh::code)); |
| 164 | } |
| 165 | } |
| 166 | } |
| 167 | |
| 168 | sub _wait_for_system { |
| 169 | my ($obj, $quiet)=@_; |
| 170 | |
| 171 | return unless $obj; |
| 172 | $obj->Wait(INFINITE); |
| 173 | _handle_wait_status($obj,$quiet) |
| 174 | } |
| 175 | |
| 176 | sub _handle_wait_status { |
| 177 | my ($obj,$quiet)=@_; |
| 178 | |
| 179 | return '' unless $obj; |
| 180 | my $pid= $obj->GetProcessID(); |
| 181 | my $job= Psh::Joblist::get_job($obj->GetProcessID()); |
| 182 | my $command = $job->{call}; |
| 183 | my $visindex= Psh::Joblist::get_job_number($pid); |
| 184 | my $verb=''; |
| 185 | |
| 186 | my $tmp= Psh::Locale::get_text('done'); |
| 187 | Psh::Util::print_out("[$visindex] \u$tmp $pid $command\n") unless $quiet; |
| 188 | Psh::Joblist::delete_job($pid); |
| 189 | return ''; |
| 190 | } |
| 191 | |
| 192 | sub fork_process { |
| 193 | _fork_process(@_); |
| 194 | return undef; |
| 195 | } |
| 196 | |
| 197 | sub get_all_users { |
| 198 | unless (@user_cache) { |
| 199 | Win32::NetAdmin::GetUsers("",FILTER_NORMAL_ACCOUNT,\@user_cache); |
| 200 | } |
| 201 | return @user_cache; |
| 202 | } |
| 203 | |
| 204 | |
| 205 | sub has_job_control { return 1; } |
| 206 | |
| 207 | sub resume_job { |
| 208 | my $job= shift; |
| 209 | $job->{assoc_obj}->Resume(); |
| 210 | } |
| 211 | |
| 212 | # |
| 213 | # void restart_job(bool FOREGROUND, int JOB_INDEX) |
| 214 | # |
| 215 | sub restart_job |
| 216 | { |
| 217 | my ($fg_flag, $job_to_start) = @_; |
| 218 | |
| 219 | my $job= Psh::Joblist::find_job($job_to_start); |
| 220 | |
| 221 | if(defined($job)) { |
| 222 | my $pid = $job->{pid}; |
| 223 | my $command = $job->{call}; |
| 224 | |
| 225 | if ($command) { |
| 226 | my $tmp=Psh::Locale::get_text('restart'); |
| 227 | my $verb = "\u$tmp"; |
| 228 | my $qRunning = $job->{running}; |
| 229 | if ($fg_flag) { |
| 230 | my $tmp= Psh::Locale::get_text('foreground'); |
| 231 | $verb = "\u$tmp"; |
| 232 | } elsif ($qRunning) { |
| 233 | # bg request, and it's already running: |
| 234 | return; |
| 235 | } |
| 236 | my $visindex = Psh::Joblist::get_job_number($pid); |
| 237 | Psh::Util::print_out("[$visindex] $verb $pid $command\n"); |
| 238 | |
| 239 | if($fg_flag) { |
| 240 | eval { _wait_for_system($job->{assoc_obj}, 0); }; |
| 241 | } elsif( !$qRunning) { |
| 242 | $job->continue; |
| 243 | } |
| 244 | } |
| 245 | } |
| 246 | } |
| 247 | |
| 248 | sub get_home_dir { |
| 249 | my $user= shift; |
| 250 | my $home; |
| 251 | if (!$user) { |
| 252 | $home=$ENV{HOME}||$ENV{USERPROFILE}||$ENV{HOMEDRIVE}.$ENV{HOMEPATH}; |
| 253 | } else { |
| 254 | # There is a UserGetAttributes function in Win32::NetAdmin but |
| 255 | # it will only work if you're admin |
| 256 | # I'v searched my registry but did not find something usable |
| 257 | } |
| 258 | return $home||"\\"; |
| 259 | } # we really should return something (profile?) |
| 260 | |
| 261 | |
| 262 | sub get_rc_files { |
| 263 | my @rc=(); |
| 264 | |
| 265 | push @rc, "\\etc\\pshrc" if -r "\\etc\\pshrc"; |
| 266 | push @rc, "$ENV{WINDIR}\\pshrc" if -r "$ENV{WINDIR}\\pshrc"; |
| 267 | my $home= Psh::OS::get_home_dir(); |
| 268 | if ($home) { push @rc, catfile($home,'pshrc') }; |
| 269 | return @rc; |
| 270 | } |
| 271 | |
| 272 | sub remove_readline_handler {1} |
| 273 | |
| 274 | sub is_path_absolute { |
| 275 | my $path= shift; |
| 276 | |
| 277 | return substr($path,0,1) eq "\\" || |
| 278 | $path=~ /^[a-zA-Z]\:\\/; |
| 279 | } |
| 280 | |
| 281 | sub get_path_extension { |
| 282 | my $extsep = $Psh::OS::PATH_SEPARATOR || ';'; |
| 283 | my $pathext = $ENV{PATHEXT} || $Registry->{"HKEY_LOCAL_MACHINE\\System\\CurrentControlSet\\Control\\Session Manager\\Environment\\PATHEXT"} || ".cmd;.bat;.exe;.com"; # Environment has precedence over LOCAL_MACHINE registry |
| 284 | return split("$extsep",$pathext); |
| 285 | } |
| 286 | |
| 287 | |
| 288 | # Simply doing backtick eval - mainly for Prompt evaluation |
| 289 | sub backtick { |
| 290 | return `@_`; |
| 291 | } |
| 292 | |
| 293 | sub abs_path { |
| 294 | my $dir= shift; |
| 295 | if (defined &Win32::GetFullPathName) { |
| 296 | my $tmp= Win32::GetFullPathName($dir); |
| 297 | $tmp=~tr:\\:/:; # otherwise prompt code etc messes up |
| 298 | return $tmp; |
| 299 | } |
| 300 | undef; |
| 301 | } |
| 302 | |
| 303 | sub getcwd_psh { |
| 304 | my $tmp; |
| 305 | if (defined &Win32::GetCwd) { |
| 306 | $tmp= Win32::GetCwd(); |
| 307 | $tmp=~tr:\\:/:; |
| 308 | } |
| 309 | return $tmp||Psh::OS::fb_getcwd(); |
| 310 | } |
| 311 | |
| 312 | |
| 313 | sub get_editor { |
| 314 | my $suggestion= shift; |
| 315 | return $suggestion||$ENV{VISUAL}||$ENV{EDITOR}||'edit'; |
| 316 | } |
| 317 | |
| 318 | |
| 319 | # From File::Spec |
| 320 | |
| 321 | |
| 322 | sub canonpath { |
| 323 | my ($path) = @_; |
| 324 | $path =~ s/^([a-z]:)/\u$1/s; |
| 325 | $path =~ s|/|\\|g; |
| 326 | $path =~ s|([^\\])\\+|$1\\|g; # xx////xx -> xx/xx |
| 327 | $path =~ s|(\\\.)+\\|\\|g; # xx/././xx -> xx/xx |
| 328 | $path =~ s|^(\.\\)+||s unless $path eq ".\\"; # ./xx -> xx |
| 329 | $path =~ s|\\\Z(?!\n)|| |
| 330 | unless $path =~ m#^([A-Z]:)?\\\Z(?!\n)#s; # xx/ -> xx return $path; |
| 331 | } |
| 332 | |
| 333 | sub catfile { |
| 334 | my $file = pop @_; |
| 335 | return $file unless @_; |
| 336 | my $dir = catdir(@_); |
| 337 | $dir .= "\\" unless substr($dir,-1) eq "\\"; |
| 338 | return $dir.$file; |
| 339 | } |
| 340 | |
| 341 | sub catdir { |
| 342 | my @args = @_; |
| 343 | foreach (@args) { |
| 344 | # append a slash to each argument unless it has one there |
| 345 | $_ .= "/" if $_ eq '' || substr($_,-1) ne "/"; |
| 346 | } |
| 347 | return canonpath(join('', @args)); |
| 348 | } |
| 349 | |
| 350 | sub file_name_is_absolute { |
| 351 | my $file= shift; |
| 352 | return scalar($file =~ m{^([a-z]:)?[\\/]}is); |
| 353 | } |
| 354 | |
| 355 | sub rootdir { |
| 356 | "\\"; |
| 357 | } |
| 358 | |
| 359 | sub splitdir { |
| 360 | my ($directories) = @_ ; |
| 361 | |
| 362 | if ( $directories !~ m|[\\/]\Z(?!\n)| ) { |
| 363 | return split( m|[\\/]|, $directories ); |
| 364 | } |
| 365 | else { |
| 366 | my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ; |
| 367 | $directories[ $#directories ]= '' ; |
| 368 | return @directories ; |
| 369 | } |
| 370 | } |
| 371 | |
| 372 | sub splitpath { |
| 373 | my ($path, $nofile) = @_; |
| 374 | my ($volume,$directory,$file) = ('','',''); |
| 375 | if ( $nofile ) { |
| 376 | $path =~ |
| 377 | m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? ) |
| 378 | (.*) |
| 379 | }xs; |
| 380 | $volume = $1; |
| 381 | $directory = $2; |
| 382 | } |
| 383 | else { |
| 384 | $path =~ |
| 385 | m{^ ( (?: [a-zA-Z]: | |
| 386 | (?:\\\\|//)[^\\/]+[\\/][^\\/]+ |
| 387 | )? |
| 388 | ) |
| 389 | ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? ) |
| 390 | (.*) |
| 391 | }xs; |
| 392 | $volume = $1; |
| 393 | $directory = $2; |
| 394 | $file = $3; |
| 395 | } |
| 396 | |
| 397 | return ($volume,$directory,$file); |
| 398 | } |
| 399 | sub rel2abs { |
| 400 | my ($path,$base ) = @_; |
| 401 | |
| 402 | if ( ! file_name_is_absolute( $path ) ) { |
| 403 | if ( !defined( $base ) || $base eq '' ) { |
| 404 | $base = Psh::OS::getcwd_psh() ; |
| 405 | } |
| 406 | elsif ( ! file_name_is_absolute( $base ) ) { |
| 407 | $base = rel2abs( $base ) ; |
| 408 | } |
| 409 | else { |
| 410 | $base = canonpath( $base ) ; |
| 411 | } |
| 412 | |
| 413 | my ( $path_directories, $path_file ) = |
| 414 | (splitpath( $path, 1 ))[1,2] ; |
| 415 | |
| 416 | my ( $base_volume, $base_directories ) = |
| 417 | splitpath( $base, 1 ) ; |
| 418 | |
| 419 | $path = catpath( |
| 420 | $base_volume, |
| 421 | catdir( $base_directories, $path_directories ), |
| 422 | $path_file |
| 423 | ) ; |
| 424 | } |
| 425 | |
| 426 | return canonpath( $path ) ; |
| 427 | } |
| 428 | |
| 429 | 1; |
| 430 | |
| 431 | __END__ |
| 432 | |
| 433 | =head1 NAME |
| 434 | |
| 435 | Psh::OS::Win - Contains Windows specific code |
| 436 | |
| 437 | |
| 438 | =head1 SYNOPSIS |
| 439 | |
| 440 | use Psh::OS::Win32; |
| 441 | |
| 442 | =head1 DESCRIPTION |
| 443 | |
| 444 | An implementation of Psh::OS for Win32 systems. This module |
| 445 | requires libwin32. |
| 446 | |
| 447 | =head1 AUTHOR |
| 448 | |
| 449 | Markus Peter, warp@spin.de |
| 450 | Omer Shenker, oshenker@iname.com |
| 451 | |
| 452 | =head1 SEE ALSO |
| 453 | |
| 454 | =cut |
| 455 | |
| 456 | # The following is for Emacs - I hope it won't annoy anyone |
| 457 | # but this could solve the problems with different tab widths etc |
| 458 | # |
| 459 | # Local Variables: |
| 460 | # tab-width:4 |
| 461 | # indent-tabs-mode:t |
| 462 | # c-basic-offset:4 |
| 463 | # perl-indent-level:4 |
| 464 | # End: |