Commit | Line | Data |
---|---|---|
86530b38 AT |
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 |