Skip to content

Commit 32244b2

Browse files
iellenbergeriellenberger
committed
Backporting private enhancements
1 parent 051a208 commit 32244b2

File tree

2 files changed

+58
-50
lines changed

2 files changed

+58
-50
lines changed

‎lib/perl5/iTools/Script/Options.pm

Lines changed: 22 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
package iTools::Script::Options;
22
use base qw( iTools::Core::Accessor );
3-
our $VERSION = "0.1";
3+
our $VERSION = "0.2";
44

55
use Data::Dumper; $Data::Dumper::Indent=1; $Data::Dumper::Sortkeys=1; # for debugging only
66

@@ -145,6 +145,9 @@ sub parse {
145145
'color!', # colored output
146146
'debug+', # debug output
147147

148+
# --- secret options ---
149+
'_pod+', # gererate POD
150+
148151
# --- options for user switching ---
149152
'isorundir=s', # set the running directory for new user (only used internally)
150153

@@ -153,8 +156,8 @@ sub parse {
153156
);
154157

155158
# --- show usage or man page ---
156-
$self->{help} && do { $self->usage() };
157-
$self->{man} && $self->man;
159+
$self->{help} && do { $self->usage() };
160+
($self->{man} || $self->{_pod}) && $self->man;
158161
$self->{version} && do { print "$::VERSION\n"; exit 0 };
159162

160163
# --- minimum arguments required ---
@@ -199,7 +202,6 @@ sub usage {
199202
usage: $Script [-qv] $usageformat
200203
201204
Options:
202-
203205
-?, --help display this message
204206
--man display the manual page for $Script
205207
-q[q], --quiet do things quietly
@@ -224,8 +226,8 @@ sub man {
224226
$vars->{COREOPTS} ||= $mancoreopts; $vars->{COREOPTS} =~ s/^\t//mg;
225227

226228
#! TODO: detect if this var has a space before it. Add a space if it doesn't.
227-
#! TODO: figure out a better way to format this se we don't have to put a space in front of it.
228-
$vars->{SYNOPSIS} ||= "$vars->{PROGRAM} {-?|--man}\n $vars->{PROGRAM} [-qv[vv]] ". $self->usageformat() ."\n";
229+
#! TODO: figure out a better way to format this so we don't have to put a space in front of it.
230+
$vars->{SYNOPSIS} ||= "$vars->{PROGRAM} {-?|--man}\n $vars->{PROGRAM} [-qv[vv]] ". $self->usageformat();
229231

230232
# --- get the terminal size ---
231233
my $cols = (Term::ReadKey::GetTerminalSize())[0] || 78;
@@ -237,10 +239,23 @@ sub man {
237239

238240
# --- interpolate variables ---
239241
foreach my $key (keys %$vars) {
240-
$content =~ s/[\$=]{$key}(?=\W)/$vars->{$key}/sg;
242+
$content =~ s/[\$=]\{$key}(?=\W)/$vars->{$key}/sg;
241243
$content =~ s/[\$=]$key(?=\W)/$vars->{$key}/sg;
242244
}
243245

246+
# --- display POD instead ---
247+
if ($self->{_pod}) {
248+
# --- remove non-pod ---
249+
my $podwords = "^=pod|^=head|^=over|^=item|^=back|^=begin|^=end|^=for|^=encoding";
250+
$content =~ s/.*?(?=$podwords)//ms; # everything before the first podword
251+
$content =~ s/(?:^=cut).*?(?=$podwords)//ms; # between '=cut' and podwords
252+
$content =~ s/(?<=^=cut).*/\n/ms; # after last '=cut'
253+
254+
# --- show POD and exit ---
255+
print $content;
256+
exit 1;
257+
}
258+
244259
# --- generate the manpage ---
245260
my $manpage;
246261
my $parser = new Pod::Text::Termcap(sentence => 0, width => $cols - 2);

‎lib/perl5/iTools/System.pm

Lines changed: 36 additions & 43 deletions
Original file line numberDiff line numberDiff line change
@@ -1,28 +1,24 @@
11
package iTools::System;
22
use base Exporter;
3-
$VERSION = "0.01";
3+
$VERSION = "0.02";
44

5-
@EXPORT_OK = (qw(
5+
@EXPORT_OK = qw(
66
fatal nofatal
77
die warn
88
system command
99
mkdir chdir mkcd symlink pushdir popdir
1010
rename link unlink
1111
vbase
12-
),
13-
#! it's getting close to the time to deprecate these:
14-
#qw(
15-
# colored
16-
# indent verbosity vprint vprintf vnprint vnprintf vtmp
17-
#)
1812
);
1913

2014
use Carp qw( cluck confess );
2115
use Cwd;
2216
use iTools::Term::ANSI qw( color );
2317
use iTools::Verbosity qw( verbosity vpush vpop vprint vprintf vindent );
2418
use IPC::Open3;
19+
use POSIX qw( WNOHANG );
2520
use Symbol;
21+
use Time::HiRes qw( usleep );
2622

2723
use strict;
2824
use warnings;
@@ -32,24 +28,11 @@ our $CONFIG = { };
3228

3329
# === Deprecated Calls ======================================================
3430
sub vbase { _varDefault(2, 'vbase', @_) }
35-
# --- the following calls will be removed in the next version of iTools::System ---
36-
#sub verbosity { iTools::Verbosity::verbosity(@_) }
37-
#sub vnprint { iTools::Verbosity::vprint(@_) }
38-
#sub vnprintf { iTools::Verbosity::vprintf(@_) }
39-
#sub vprint { iTools::Verbosity::vprint(shift, '>'. shift, @_) }
40-
#sub vprintf { iTools::Verbosity::vprintf(shift, '>'. shift, @_) }
41-
#sub indent { iTools::Verbosity::vindent(@_) }
42-
#sub vtmp(&$) {
43-
# my ($code, $level) = @_;
44-
# vpush $level; my $retval = &$code; vpop;
45-
# return $retval;
46-
#}
4731
sub logfile { iTools::Verbosity::vlogfile(@_) }
4832
sub logonly {
4933
iTools::Verbosity::vloglevel(iTools::Verbosity::verbosity());
5034
vpush -3;
5135
}
52-
#sub colored { iTools::Term::ANSI::colored(@_) }
5336

5437
# === Accessors =============================================================
5538
# --- should errors be fatal? ---
@@ -115,10 +98,10 @@ sub system {
11598
}
11699

117100
# --- run the command ---
118-
vprint vbase(), color('c', "executing: ") . join(' ', @cmd) ."\n";
101+
vprint vbase(), '>'. color('c', "executing: ") . join(' ', @cmd) ."\n";
119102
my $retval = system(@cmd) == 0 && do {
120103
# --- clean exit ---
121-
vprint vbase() + 1, color('g', "command completed successfully") ."\n";
104+
vprint vbase() + 1, '>'. color('g', "command completed successfully") ."\n";
122105
return 0;
123106
};
124107

@@ -138,16 +121,26 @@ sub system {
138121
}
139122

140123
# --- qx replacement ---
141-
sub command($;%) {
142-
my ($cmd, %extinfo) = @_;
124+
sub command($;\%) {
125+
my ($cmd, $extinfo) = @_;
143126

144127
# --- use open3 to run command and capture stdout and stderr ---
145128
my ($out, $err) = (gensym, gensym);
146-
vprint vbase(), color('c', "executing: ") ."$cmd\n";
129+
vprint vbase(), '>'. color('c', "executing: ") ."$cmd\n";
147130
my $pid = open3 undef, $out, $err, $cmd;
148131

149132
# --- wait for process to complete and capture return status ---
150-
waitpid $pid, 0;
133+
local $/;
134+
my ($outbuff, $errbuff) = ('', '');
135+
136+
my $deadpid;
137+
do {
138+
usleep 10000;
139+
$deadpid = waitpid $pid, WNOHANG;
140+
$outbuff .= <$out> || '';
141+
$errbuff .= <$err> || '';
142+
} until $deadpid;
143+
151144
my $stat = $? >> 8;
152145
my $message;
153146

@@ -166,21 +159,21 @@ sub command($;%) {
166159
# --- command executed successfully ---
167160
else {
168161
$message = 'command completed successfully';
169-
vprint vbase() + 1, color('g', "$message") ."\n";
162+
vprint vbase() + 1, '>'. color('g', "$message") ."\n";
170163
}
171164

172165
# --- build the %extinfo hash ---
173166
local $/;
174-
%extinfo = (
175-
stdout => <$out> || '',
176-
stderr => <$err> || '',
167+
%$extinfo = (
168+
stdout => $outbuff || '',
169+
stderr => $errbuff || '',
177170
pid => $pid,
178171
status => $stat,
179172
message => $message,
180173
);
181174

182175
# --- return stdout ---
183-
return wantarray ? split(/[\r\n]/, $extinfo{stdout}) : $extinfo{stdout};
176+
return wantarray ? split(/[\r\n]/, $extinfo->{stdout}) : $extinfo->{stdout};
184177
}
185178

186179
# === Filesystem Tools ======================================================
@@ -192,7 +185,7 @@ sub mkdir {
192185
PATH: foreach my $path (@_) {
193186
next if -d $path; # do nothing if it already exists
194187

195-
vprint vbase(), color('c', "mkdir: ") ."$path\n";
188+
vprint vbase(), '>'. color('c', "mkdir: ") ."$path\n";
196189

197190
# --- make a directory list ---
198191
my @dirs = split /\//, $path; # split path into components
@@ -205,7 +198,7 @@ sub mkdir {
205198

206199
# --- skip dir if it already exists ---
207200
if (-d $path) {
208-
vprint vbase() + 1, "mkdir $path". color('y', " (already exists)") ."\n";
201+
vprint vbase() + 1, '>'. "mkdir $path". color('y', " (already exists)") ."\n";
209202
next;
210203
}
211204

@@ -217,14 +210,14 @@ sub mkdir {
217210
$goodpath = $retval = 0;
218211
last;
219212
}
220-
vprint vbase() + 1, "mkdir $path\n";
213+
vprint vbase() + 1, '>'. "mkdir $path\n";
221214
mkdir $path, 0755 or do {
222215
iTools::System::die("error creating directory '$path': $!");
223216
$goodpath = $retval = 0;
224217
last;
225218
}
226219
}
227-
vprint vbase() + 1, color('g', "path created") ."\n"
220+
vprint vbase() + 1, '>'. color('g', "path created") ."\n"
228221
if $goodpath;
229222
}
230223

@@ -237,7 +230,7 @@ sub mkdir {
237230
# --- chdir wrapper ---
238231
sub chdir {
239232
my $path = shift;
240-
vprint vbase(), color('c', "chdir: ") ."$path\n";
233+
vprint vbase(), '>'. color('c', "chdir: ") ."$path\n";
241234
chdir $path or iTools::System::die("can't chdir to '$path': $!") && return undef;
242235
return $path;
243236
}
@@ -272,38 +265,38 @@ sub symlink {
272265
return undef;
273266
}
274267

275-
vprint vbase(), color('c', "symlink: ") ."$source -> $dest\n";
268+
vprint vbase(), '>'. color('c', "symlink: ") ."$source -> $dest\n";
276269

277270
# --- delete old symlink if possible ---
278271
if (-l $dest) {
279-
vprint vbase() + 1, color('y', "deleteting old symlink") ."\n";
272+
vprint vbase() + 1, '>'. color('y', "deleteting old symlink") ."\n";
280273
unlink $dest or iTools::System::die "could not delete old symlink\n" && return undef;
281274
} elsif (-e $dest) {
282275
iTools::System::die "cannot create symlink $dest, file is in the way\n" && return undef;
283276
}
284277

285278
symlink $source, $dest or iTools::System::die "error creating symlink $dest" && return undef;
286-
vprint vbase() + 1, color('g', "symlink created") ."\n";
279+
vprint vbase() + 1, '>'. color('g', "symlink created") ."\n";
287280
return 1;
288281
}
289282
# --- create a hard link ---
290283
sub link {
291284
my ($ori, $new) = @_;
292-
vprint vbase(), color('c', "link: ") ."$ori -> $new\n";
285+
vprint vbase(), '>'. color('c', "link: ") ."$ori -> $new\n";
293286
link $ori, $new
294287
or iTools::System::die "could not create link\n" && return undef;
295288
}
296289

297290
# --- delete a file ---
298291
sub unlink {
299-
vprint vbase(), color('c', "unlink: ") . join(' ', @_) ."\n";
292+
vprint vbase(), '>'. color('c', "unlink: ") . join(' ', @_) ."\n";
300293
unlink @_ or iTools::System::die "could not delete files\n" && return;
301294
}
302295

303296
# --- rename wrapper ---
304297
sub rename {
305298
my ($old, $new) = @_;
306-
vprint vbase(), color('c', "rename: ") ."$old -> $new\n";
299+
vprint vbase(), '>'. color('c', "rename: ") ."$old -> $new\n";
307300
rename $old, $new or return iTools::System::die("can't rename '$old' to '$new': $!") && return undef;
308301
return $new;
309302
}

0 commit comments

Comments
 (0)