[OpenSPARC-T2-DV] / tools / perl-5.8.0 / lib / site_perl / 5.8.0 / Psh / OS / Win.pm

package Psh::OS::Win;

use strict;
require Psh::Util;

eval {
	use Win32;
	use Win32::TieRegistry 0.20;
	use Win32::Process;
	use Win32::Console;
	use Win32::NetAdmin;
};

if ($@) {
	Psh::Util::print_error_i18n('no_libwin32');
	die "\n";
}

my $console= new Win32::Console();
my @user_cache=();

#
# For documentation see Psh::OS::Unix
#

$Psh::OS::PATH_SEPARATOR=';';
$Psh::OS::FILE_SEPARATOR='\\';

$Psh::history_file = "psh_history";

sub set_window_title {
	my $title=shift;
	$console->Title($title);
}


sub reinstall_resize_handler {
	# actually we have no 'handlers' here but instead simply do it
	my ($cols,$rows)=$console->Size();
	$ENV{COLUMNS}=$cols;
	$ENV{ROWS}=$rows;
}

sub get_hostname {
	my $name_from_reg = $Registry->{"HKEY_LOCAL_MACHINE\\System\\CurrentControlSet\\Control\\ComputerName\\ComputerName\\ComputerName"};
	return $name_from_reg if $name_from_reg;
	return 'localhost';
}

sub get_known_hosts {
	my $hosts_file = "$ENV{windir}\\HOSTS";
	if (open(F_KNOWNHOST,"< $hosts_file")) {
		my $hosts_text = join('', <F_KNOWNHOST>);
		close(F_KNOWNHOST);
		return Psh::Util::parse_hosts_file($hosts_text);
	} else {
		return ("localhost");
	}
}

#
# void display_pod(text)
#
sub display_pod {
	my $tmp= Psh::OS::tmpnam();
	my $text= shift;

	open( TMP,">$tmp");
	print TMP $text;
	close(TMP);

	eval {
		require Pod::Text;
		Pod::Text::pod2text($tmp,*STDOUT);
	};
	print $text if $@;

	unlink($tmp);
}

sub inc_shlvl {
	if (! $ENV{SHLVL}) {
		$Psh::login_shell = 1;
		$ENV{SHLVL} = 1;
	} else {
		$Psh::login_shell = 0;
		$ENV{SHLVL}++;
	}
}

sub execute_complex_command {
	my @array= @{shift()};
	my $fgflag= shift @array;
	my @return_val;
	my $pgrp_leader=0;
	my $success= 0;
	my $pid;
	my $string='';
	my @tmp;

	if($#array) {
		Psh::Util::print_error("No piping yet.\n");
		return ();
	}

	my $obj;
	for( my $i=0; $i<@array; $i++) {
		my ($strategy, $how, $options, $words, $text, $opt)= @{$array[$i]};
		local $Psh::current_options=$opt;
		my $line= join(' ',@$words);
		my ($eval_thingie,$bgflag);
		($success,$eval_thingie,$words,$bgflag,@return_val)= $strategy->execute( \$line, $words, $how, 0);

		my @tmp;

		if( defined($eval_thingie)) {
			($obj,$success,@tmp)= _fork_process($eval_thingie,$fgflag,$text,undef,$words);
		}
		if( @return_val < 1 ||
			!defined($return_val[0])) {
			@return_val= @tmp;
		}
		$string=$text;
	}
	if ($obj) {
		my $pid=$obj->GetProcessID();
		my $job=Psh::Joblist::create_job($pid,$string,$obj);
		if( $fgflag) {
			_wait_for_system($obj, 1);
		} else {
			my $visindex= Psh::Joblist::get_job_number($pid);
			Psh::Util::print_out("[$visindex] Background $pid $string\n");
		}
	}
	return ($success,@return_val);
}

sub _fork_process {
	local( $Psh::code, $Psh::fgflag, $Psh::string, $Psh::options,
		   $Psh::words) = @_;
	local $Psh::pid;

	# TODO: perhaps we should use Win32::Process?
	# hmm - won't help alot :-( - warp
	# print_error_i18n('no_jobcontrol') unless $Psh::fgflag;

	if( ref($Psh::code) eq 'CODE') {
		return (0,&{$Psh::code});
	} else {
		if ($Psh::words) {
			my $obj;
			Win32::Process::Create($obj,
								   @$Psh::words->[0],
								   $Psh::string,
								   0,
								   NORMAL_PRIORITY_CLASS,
								   ".");
			return ($obj,0);
			# We are passing around objects instead of pid because
			# Win32::Process currently only allows me to create objects,
			# not look them up via pid
		} else {
			return (0,system($Psh::code));
		}
	}
}

sub _wait_for_system {
	my ($obj, $quiet)=@_;

	return unless $obj;
	$obj->Wait(INFINITE);
	_handle_wait_status($obj,$quiet)
}

sub _handle_wait_status {
	my ($obj,$quiet)=@_;

	return '' unless $obj;
	my $pid= $obj->GetProcessID();
	my $job= Psh::Joblist::get_job($obj->GetProcessID());
	my $command = $job->{call};
	my $visindex= Psh::Joblist::get_job_number($pid);
	my $verb='';

	my $tmp= Psh::Locale::get_text('done');
	Psh::Util::print_out("[$visindex] \u$tmp $pid $command\n") unless $quiet;
	Psh::Joblist::delete_job($pid);
	return '';
}

sub fork_process {
	_fork_process(@_);
	return undef;
}

sub get_all_users {
	unless (@user_cache) {
		Win32::NetAdmin::GetUsers("",FILTER_NORMAL_ACCOUNT,\@user_cache);
	}
	return @user_cache;
}


sub has_job_control { return 1; }

sub resume_job {
	my $job= shift;
	$job->{assoc_obj}->Resume();
}

#
# void restart_job(bool FOREGROUND, int JOB_INDEX)
#
sub restart_job
{
	my ($fg_flag, $job_to_start) = @_;

	my $job= Psh::Joblist::find_job($job_to_start);

	if(defined($job)) {
		my $pid = $job->{pid};
		my $command = $job->{call};

		if ($command) {
			my $tmp=Psh::Locale::get_text('restart');
			my $verb = "\u$tmp";
			my $qRunning = $job->{running};
			if ($fg_flag) {
				my $tmp= Psh::Locale::get_text('foreground');
				$verb = "\u$tmp";
			} elsif ($qRunning) {
			  # bg request, and it's already running:
			  return;
			}
			my $visindex = Psh::Joblist::get_job_number($pid);
			Psh::Util::print_out("[$visindex] $verb $pid $command\n");

			if($fg_flag) {
				eval { _wait_for_system($job->{assoc_obj}, 0); };
			} elsif( !$qRunning) {
				$job->continue;
			}
		}
	}
}

sub get_home_dir {
	my $user= shift;
	my $home;
	if (!$user) {
		$home=$ENV{HOME}||$ENV{USERPROFILE}||$ENV{HOMEDRIVE}.$ENV{HOMEPATH};
	} else {
		# There is a UserGetAttributes function in Win32::NetAdmin but
		# it will only work if you're admin
		# I'v searched my registry but did not find something usable
	}
	return $home||"\\";
} # we really should return something (profile?)


sub get_rc_files {
	my @rc=();

	push @rc, "\\etc\\pshrc" if -r "\\etc\\pshrc";
	push @rc, "$ENV{WINDIR}\\pshrc" if -r "$ENV{WINDIR}\\pshrc";
	my $home= Psh::OS::get_home_dir();
	if ($home) { push @rc, catfile($home,'pshrc') };
	return @rc;
}

sub remove_readline_handler {1}

sub is_path_absolute {
	my $path= shift;

	return substr($path,0,1) eq "\\" ||
		$path=~ /^[a-zA-Z]\:\\/;
}

sub get_path_extension {
	my $extsep = $Psh::OS::PATH_SEPARATOR || ';';
	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
	return split("$extsep",$pathext);
}


# Simply doing backtick eval - mainly for Prompt evaluation
sub backtick {
	return `@_`;
}

sub abs_path {
	my $dir= shift;
	if (defined &Win32::GetFullPathName) {
		my $tmp= Win32::GetFullPathName($dir);
		$tmp=~tr:\\:/:; # otherwise prompt code etc messes up
		return $tmp;
	}
	undef;
}

sub getcwd_psh {
	my $tmp;
	if (defined &Win32::GetCwd) {
		$tmp= Win32::GetCwd();
		$tmp=~tr:\\:/:;
	}
	return $tmp||Psh::OS::fb_getcwd();
}


sub get_editor {
	my $suggestion= shift;
    return $suggestion||$ENV{VISUAL}||$ENV{EDITOR}||'edit';
}


# From File::Spec


sub canonpath {
    my ($path) = @_;
    $path =~ s/^([a-z]:)/\u$1/s;
    $path =~ s|/|\\|g;
    $path =~ s|([^\\])\\+|$1\\|g;                  # xx////xx  -> xx/xx
    $path =~ s|(\\\.)+\\|\\|g;                     # xx/././xx -> xx/xx
    $path =~ s|^(\.\\)+||s unless $path eq ".\\";  # ./xx      -> xx
    $path =~ s|\\\Z(?!\n)||
	  unless $path =~ m#^([A-Z]:)?\\\Z(?!\n)#s;   # xx/       -> xx    return $path;
}

sub catfile {
    my $file = pop @_;
    return $file unless @_;
    my $dir = catdir(@_);
    $dir .= "\\" unless substr($dir,-1) eq "\\";
    return $dir.$file;
}

sub catdir {
    my @args = @_;
    foreach (@args) {
        # append a slash to each argument unless it has one there
        $_ .= "/" if $_ eq '' || substr($_,-1) ne "/";
    }
    return canonpath(join('', @args));
}

sub file_name_is_absolute {
	my $file= shift;
    return scalar($file =~ m{^([a-z]:)?[\\/]}is);
}

sub rootdir {
	"\\";
}

sub splitdir {
    my ($directories) = @_ ;

    if ( $directories !~ m|[\\/]\Z(?!\n)| ) {
        return split( m|[\\/]|, $directories );
    }
    else {
        my( @directories )= split( m|[\\/]|, "${directories}dummy" ) ;
        $directories[ $#directories ]= '' ;
        return @directories ;
    }
}

sub splitpath {
    my ($path, $nofile) = @_;
    my ($volume,$directory,$file) = ('','','');
    if ( $nofile ) {
        $path =~
            m{^( (?:[a-zA-Z]:|(?:\\\\|//)[^\\/]+[\\/][^\\/]+)? )
                 (.*)
             }xs;
        $volume    = $1;
        $directory = $2;
    }
    else {
        $path =~
            m{^ ( (?: [a-zA-Z]: |
                      (?:\\\\|//)[^\\/]+[\\/][^\\/]+
                  )?
                )
                ( (?:.*[\\\\/](?:\.\.?\Z(?!\n))?)? )
                (.*)
             }xs;
        $volume    = $1;
        $directory = $2;
        $file      = $3;
    }
 
    return ($volume,$directory,$file);
}
sub rel2abs {
    my ($path,$base ) = @_;

    if ( ! file_name_is_absolute( $path ) ) {
        if ( !defined( $base ) || $base eq '' ) {
            $base = Psh::OS::getcwd_psh() ;
        }
        elsif ( ! file_name_is_absolute( $base ) ) {
            $base = rel2abs( $base ) ;
        }
        else {
            $base = canonpath( $base ) ;
        }
 
        my ( $path_directories, $path_file ) =
            (splitpath( $path, 1 ))[1,2] ;
 
        my ( $base_volume, $base_directories ) =
		  splitpath( $base, 1 ) ;
 
        $path = catpath(
						$base_volume,
						catdir( $base_directories, $path_directories ),
						$path_file
					   ) ;
    }
 
    return canonpath( $path ) ;
}

1;

__END__

=head1 NAME

Psh::OS::Win - Contains Windows specific code


=head1 SYNOPSIS

	use Psh::OS::Win32;

=head1 DESCRIPTION

An implementation of Psh::OS for Win32 systems. This module
requires libwin32.

=head1 AUTHOR

Markus Peter, warp@spin.de
Omer Shenker, oshenker@iname.com

=head1 SEE ALSO

=cut

# The following is for Emacs - I hope it won't annoy anyone
# but this could solve the problems with different tab widths etc
#
# Local Variables:
# tab-width:4
# indent-tabs-mode:t
# c-basic-offset:4
# perl-indent-level:4
# End:
Commit	Line	Data
86530b38 AT	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: