projtool.pl: do not attempt to check unset error codes
[girocco.git] / Girocco / CLIUtil.pm
blobcf84cf221c3bbcaeb9dbccbc35dbad934ce9a86c
1 # Girocco::CLIUtil.pm -- Command Line Interface Utility Functions
2 # Copyright (C) 2016 Kyle J. McKay. All rights reserved.
4 # This program is free software; you can redistribute it and/or
5 # modify it under the terms of the GNU General Public License
6 # as published by the Free Software Foundation; either version 2
7 # of the License, or (at your option) any later version.
9 # This program is distributed in the hope that it will be useful,
10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 # GNU General Public License for more details.
14 # You should have received a copy of the GNU General Public License
15 # along with this program; if not, write to the Free Software
16 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
19 ## IMPORTANT
21 ## This package MUST NOT be used by any CGI script as it cancels
22 ## the effect of CGI::Carp::fatalsToBrowser which could result in the
23 ## output of a CGI script becoming unparseable by the web server!
26 package Girocco::CLIUtil;
28 use strict;
29 use warnings;
31 use base qw(Exporter);
32 our ($VERSION, @EXPORT, @EXPORT_OK);
34 BEGIN {
35 @EXPORT = qw(
36 diename recreate_file strict_bool
37 is_yes is_no is_yesno valid_bool clean_bool
38 prompt prompt_or_die
39 ynprompt ynprompt_or_die
40 prompt_noecho prompt_noecho_or_die
41 prompt_noecho_nl prompt_noecho_nl_or_die
42 yes_to_continue yes_to_continue_or_die
43 get_all_users get_user get_all_projects get_project
44 get_full_users nice_me setup_pager setup_pager_stdout
45 pager_in_use get_project_harder
47 @EXPORT_OK = qw(
48 _parse_options _prompt_rl _prompt_rl_or_die
49 check_passwd_match _which
51 *VERSION = \'1.0';
54 use File::Basename;
55 use File::Spec;
56 use Cwd qw(getcwd);
57 use POSIX qw(:fcntl_h);
58 use Girocco::Config;
59 use Girocco::Util;
60 use Girocco::HashUtil;
61 use Girocco::CGI;
62 BEGIN {noFatalsToBrowser}
64 my $have_rl;
65 BEGIN {eval{
66 require Term::ReadLine;
67 $have_rl = 1;
71 package Girocco::CLIUtil::NoEcho;
73 sub new {
74 my $class = shift; # ignored
75 my $self = bless {};
76 my $fd = shift || 0;
77 $self->{fd} = $fd;
78 $self->{ios} = POSIX::Termios->new;
79 $self->{ios}->getattr($self->{fd});
80 my $noecho = POSIX::Termios->new;
81 $noecho->getattr($fd);
82 $noecho->setlflag($noecho->getlflag & ~(&POSIX::ECHO));
83 $noecho->setattr($fd, &POSIX::TCSANOW);
84 $self;
87 sub DESTROY {
88 my $self = shift;
89 $self->{ios}->setattr($self->{fd}, &POSIX::TCSANOW);
94 package Girocco::CLIUtil::Progress;
96 use Scalar::Util qw(looks_like_number);
97 use Time::HiRes qw(gettimeofday);
99 sub fractime() { return scalar(gettimeofday) }
101 my $_init;
102 BEGIN { $_init = sub {
103 my $self = shift;
104 my $max = shift;
105 looks_like_number($max) && $max >= 0 or $max = 100;
106 my $title = shift;
107 defined($title) or $title = "";
108 $title =~ s/:+$//;
109 $title ne "" or $title = "Progress";
110 my $lastupd = $self->{lastupd};
111 my $shown1 = $self->{shown1};
112 looks_like_number($lastupd) or $lastupd = fractime + 2;
113 %$self = (
114 title => $title,
115 max => $max,
116 cur => 0,
117 len => 0,
118 lastupd => $lastupd
120 defined($shown1) and $self->{shown1} = $shown1;
121 $self;
124 sub new {
125 my $class = shift || __PACKAGE__;
126 my $self = bless {}, $class;
127 unshift(@_, $self);
128 select((select(STDERR),$|=1)[0]);
129 select((select(STDOUT),$|=1)[0]);
130 return &$_init;
133 sub reset {
134 my $self = $_[0];
135 $self->clear;
136 my $wasvis = $self->{wasvis};
137 &$_init;
138 $wasvis and $self->show;
139 $self;
142 sub val { $_[0]->{cur} }
143 sub done { $_[0]->{cur} >= $_[0]->{max} }
145 sub update {
146 my $self = shift;
147 !$self->{max} and return;
148 my $last = $self->{cur};
149 my $newcur = shift;
150 looks_like_number($newcur) or $newcur = $last + 1;
151 $newcur >= $last or $newcur = $last;
152 $newcur > $self->{max} and $newcur = $self->{max};
153 $self->{cur} = $newcur unless $newcur == $last;
154 my $now = fractime;
155 if ($self->{shown1} && $newcur > $last && $newcur >= $self->{max} ||
156 $now >= $self->{lastupd} + 1) {
157 $self->{lastupd} = $now;
158 !$self->{len} || $newcur != $last and $self->show;
162 sub show {
163 my $self = shift;
164 delete $self->{wasvis};
165 !$self->{max} and return;
166 my $p = int((100 * $self->{cur} / $self->{max}) + 0.5);
167 $p > 100 and $p = 100;
168 $p == 100 && $self->{cur} < $self->{max} and $p = 99;
169 my $status = sprintf("%s: %3d%% (%d/%d)", $self->{title},
170 $p, $self->{cur}, $self->{max});
171 my $newlen = length($status);
172 $self->{len} > $newlen and $status .= " " x ($self->{len} - $newlen);
173 printf STDERR "%s\r", $status;
174 $self->{len} = $newlen;
175 $self->{shown1} = 1;
178 sub clear {
179 my $self = shift;
180 if ($self->{len}) {
181 printf STDERR "%s\r", " " x $self->{len};
182 $self->{len} = 0;
183 $self->{wasvis} = 1;
187 sub restore {
188 my $self = shift;
189 $self->{wasvis} and $self->show;
192 sub emitfh {
193 my $self = shift;
194 my $fh = shift;
195 my $msg = join(' ', @_);
196 defined($msg) or return;
197 chomp $msg;
198 $msg ne '' or return;
199 $self->clear;
200 printf $fh "%s\n", $msg;
201 $self->restore;
204 sub emit {
205 my $self = shift;
206 $self->emitfh(\*STDOUT, @_);
209 sub warn {
210 my $self = shift;
211 $self->emitfh(\*STDERR, @_);
214 sub DESTROY {
215 my $self = shift;
216 $self->clear;
219 }# END package Girocco::CLIUtil::Progress
221 my $diename;
222 BEGIN {$diename = ""}
223 sub diename {
224 my $result = $diename;
225 $diename = join(" ", @_) if @_;
226 $result;
229 # Parse Options
231 # Remove any leading options matching the given specs from the @ARGV array and
232 # store them as indicated. Parsing stops when an unknown option is encountered,
233 # "--" is encountered (in which case it's removed) or a non-option is encountered.
234 # Note that "-" by itself is considered a non-option argument.
236 # Option bundling for single-letter options is NOT supported.
238 # Optional first arg is CODE ref:
239 # sub {my ($err, $opt) = @_; ...}
240 # with $err of '?' meaning $opt is unknown
241 # with $err of ':' meaning $opt is missing its argument
242 # $opt is the full option as given on the command line (including leading - etc.)
243 # the default if omitted dies with an error
244 # If the sub returns, _parse_options exits immediately with 0
246 # The rest of the arguments form pairs:
247 # "spec" => ref
248 # where ref must be either a SCALAR ref or a CODE ref, if it's neither
249 # then the "spec" => ref pair is silently ignored.
250 # "spec" can be:
251 # "name" -- an incrementing flag (matches -name and --name)
252 # ":name" -- an option with a value (matches -name=val and --name=val)
253 # Using option "--name" matches spec "name" if given otherwise matches spec
254 # ":name" if given and there's at least one more argument (if not the ':' error
255 # happens).
256 # Using option "--name=val" only matches spec ":name" (but "val" can be "").
257 # For flags, a SCALAR ref is incremented, a CODE ref is called with no arguments.
258 # For values (":name" specs) a SCALAR ref is assigned the value a CODE ref is
259 # called with the value as its single argument.
261 # _parse_options returns 1 as long as there were no errors
262 sub _parse_options {
263 local $_;
264 my $failsub = sub {die((($_[0]eq'?')?"unrecognized":"missing argument for")." option \"$_[1]\"\n")};
265 $failsub = shift if @_ && ref($_[0]) eq "CODE";
266 my %opts = ();
267 while (@_ >= 2) {
268 if (defined($_[0]) && $_[0] =~ /^:?[^-:\s]/ &&
269 defined($_[1]) && (ref($_[1]) eq "SCALAR" || ref($_[1]) eq "CODE")) {
270 $opts{$_[0]} = $_[1];
272 shift;
273 shift;
275 while (@ARGV && $ARGV[0] =~ /^--?[^-:\s]/) {
276 my $opt = shift @ARGV;
277 my $sopt = $opt;
278 $sopt =~ s/^--?//;
279 if ($sopt =~ /^([^=]+)=(.*)$/) {
280 my ($name, $val) = ($1, $2);
281 if ($opts{":$name"}) {
282 ${$opts{":$name"}} = $val if ref($opts{":$name"}) eq "SCALAR";
283 &{$opts{":$name"}}($val) if ref($opts{":$name"}) eq "CODE";
284 } else {
285 &$failsub('?', $opt);
286 return 0;
288 } elsif ($opts{$sopt}) {
289 ++${$opts{$sopt}} if ref($opts{$sopt}) eq "SCALAR";
290 &{$opts{$sopt}}() if ref($opts{$sopt}) eq "CODE";
291 } elsif ($opts{":$sopt"}) {
292 &$failsub(':', $opt),return(0) unless @ARGV;
293 my $val = shift @ARGV;
294 ${$opts{":$sopt"}} = $val if ref($opts{":$sopt"} eq "SCALAR");
295 &{$opts{":$sopt"}}($val) if ref($opts{":$sopt"} eq "CODE");
296 } else {
297 &$failsub('?', $opt);
298 return 0;
301 if (@ARGV && $ARGV[0] eq "--") {
302 shift @ARGV;
303 return 1;
305 if (@ARGV && $ARGV[0] =~ /^-./) {
306 &$failsub('?', $ARGV[0]);
307 return 0;
309 return 1;
312 sub recreate_file {
313 open F, '>', $_[0] or die "failed to create $_[0]: $!\n";
314 close F;
317 sub is_yes {
318 my $b = shift;
319 my $strict = shift;
320 defined ($b) or $b = "";
321 return lc($b) eq "yes" || (!$strict && lc($b) eq "y");
324 sub is_no {
325 my $b = shift;
326 my $strict = shift;
327 defined ($b) or $b = "";
328 return lc($b) eq "no" || (!$strict && lc($b) eq "n");
331 sub is_yesno {
332 return is_yes(@_) || is_no(@_);
335 my %boolvals;
336 BEGIN {
337 %boolvals = (
338 true => 1,
339 on => 1,
340 yes => 1,
341 y => 1,
342 1 => 1,
344 false => 0,
345 off => 0,
346 no => 0,
347 n => 0,
348 0 => 0,
352 sub valid_bool {
353 exists($boolvals{lc($_[0])});
356 sub clean_bool {
357 my $b = shift || 0;
358 return $boolvals{lc($b)} || 0;
361 sub _prompt_rl {
362 my ($norl, $prompt, $default, $promptsfx) = @_;
363 ! -t STDIN and $norl = 1;
364 defined($promptsfx) or $promptsfx = ': ';
365 defined($prompt) or $prompt = '';
366 my $ds = '';
367 $ds = " [" . $default . "]" if defined($default);
368 if ($have_rl && !$norl) {
369 my $rl = Term::ReadLine->new(basename($0), \*STDIN, \*STDOUT);
370 $rl->ornaments(0);
371 $_ = $rl->readline($prompt . $ds . $promptsfx);
372 $rl->addhistory($_) if defined($_) && $_ =~ /\S/;
373 } else {
374 print $prompt, $ds, $promptsfx;
375 $_ = <STDIN>;
377 return undef unless defined($_);
378 chomp;
379 return $_ eq '' && defined($default) ? $default : $_;
382 sub prompt {
383 return _prompt_rl(undef, @_);
386 sub ynprompt {
387 my $result;
388 my @args = @_;
389 $args[2] = "? " unless defined$args[2];
391 $result = prompt(@args);
392 return undef unless defined($result);
393 redo unless is_yesno($result);
395 return clean_bool($result);
398 sub _prompt_rl_or_die {
399 my $result = _prompt_rl(@_);
400 unless (defined($result)) {
401 my $nm = $diename;
402 defined($nm) or $nm = "";
403 $nm eq "" or $nm .= " ";
404 die "\n${nm}aborted\n";
406 $result;
409 sub prompt_or_die {
410 return _prompt_rl_or_die(undef, @_);
413 sub ynprompt_or_die {
414 my $result = ynprompt(@_);
415 unless (defined($result)) {
416 my $nm = $diename;
417 defined($nm) or $nm = "";
418 $nm eq "" or $nm .= " ";
419 die "\n${nm}aborted\n";
421 $result;
424 sub prompt_noecho {
425 my $ne = Girocco::CLIUtil::NoEcho->new;
426 _prompt_rl(1, @_);
429 sub prompt_noecho_or_die {
430 my $ne = Girocco::CLIUtil::NoEcho->new;
431 _prompt_rl_or_die(1, @_);
434 sub prompt_noecho_nl {
435 my $result = prompt_noecho(@_);
436 print "\n";
437 $result;
440 sub prompt_noecho_nl_or_die {
441 my $result = prompt_noecho_or_die(@_);
442 print "\n";
443 $result;
446 sub yes_to_continue {
447 return !!ynprompt(($_[0]||"Continue (enter \"yes\" to continue)"), "no");
450 sub yes_to_continue_or_die {
451 unless (ynprompt_or_die(($_[0]||"Continue (enter \"yes\" to continue)"), "no")) {
452 my $nm = $diename;
453 defined($nm) or $nm = "";
454 $nm .= " " if $nm ne "";
455 die "${nm}aborted\n";
457 return 1;
460 my @user_list;
461 my $user_list_loaded;
462 my @full_user_list;
463 my $full_user_list_loaded;
465 # If single argument is true, return ALL passwd entries not just "...@..." ones
466 sub _get_all_users_internal {
467 my $full = shift || 0;
468 if ($full) {
469 return @full_user_list if $full_user_list_loaded;
470 } else {
471 return @user_list if $user_list_loaded;
473 my $passwd_file = jailed_file("/etc/passwd");
474 open my $fd, '<', $passwd_file or die "could not open \"$passwd_file\": $!\n";
475 my $line = 0;
476 my @users;
477 if ($full) {
478 @users = map {/^([^:\s#][^:\s]*):[^:]*:(-?\d+):(-?\d+)(:|$)/
479 ? [++$line,split(':',$_,-1)] : ()} <$fd>;
480 } else {
481 @users = map {/^([^:_\s#][^:\s#]*):[^:]+:(\d{5,}):(\d+):([^:,][^:]*)/
482 ? [++$line,$1,$2,$3,split(',',$4)] : ()} <$fd>;
484 close $fd;
485 if ($full) {
486 $$_[5] = [split(',', $$_[5])] foreach @users;
487 @full_user_list = @users;
488 $full_user_list_loaded = 1;
489 } else {
490 @users = grep({$$_[4] =~ /\@/} @users);
491 @user_list = @users;
492 $user_list_loaded = 1;
494 @users;
497 # Return array of arrayref where each arrayref has:
498 # [0] = ordering ordinal from $chroot/etc/passwd
499 # [1] = user name
500 # [2] = user id number
501 # [3] = user group number
502 # [4] = user email
503 # [5] = user UUID (text as 8x-4x-4x-4x-12x) or undef if none
504 # [6] = user creation date as YYYYMMDD_HHMMSS (UTC) or undef if none
505 sub get_all_users { return _get_all_users_internal; }
507 # Return array of arrayref where each arrayref has:
508 # [0] = ordering ordinal from $chroot/etc/passwd
509 # [1] = user name
510 # [2] = user password field (usually "x")
511 # [3] = user id number
512 # [4] = user group number
513 # [5] = [info fields] from passwd line (usually email,uuid,creation)
514 # [6] = home dir field
515 # [7] = shell field
516 # [...] possibly more, but [7] is usually max
517 sub get_full_users { return _get_all_users_internal(1); }
519 # Result of Girocco::User->load or fatal die if that fails
520 # Returns undef if passed undef or ""
521 sub get_user {
522 my $username = shift;
523 defined($username) && $username ne "" or return undef;
524 Girocco::User::does_exist($username, 1) or die "No such user: \"$username\"\n";
525 my $user;
526 eval {
527 $user = Girocco::User->load($username);
529 } && $user->{uid} or die "Could not load user \"$username\"\n";
530 $user;
533 my @project_list;
534 my $project_list_loaded;
536 # Return array of arrayref where each arrayref has:
537 # [0] = ordering ordinal from $chroot/etc/group
538 # [1] = group name
539 # [2] = group password hash
540 # [3] = group id number
541 # [4] = owner from gitproj.list
542 # [5] = list of comma-separated push user names (can be "") or ":" if mirror
543 sub get_all_projects {
544 return @project_list if $project_list_loaded;
545 my $fd;
546 my $projlist_file = $Girocco::Config::projlist_cache_dir."/gitproj.list";
547 open $fd, '<', $projlist_file or die "could not open \"$projlist_file\": $!\n";
548 my $chomper = sub {chomp(my $x = shift); $x;};
549 my %owners = map {(split(/\s+/, &$chomper($_), 3))[0,2]} <$fd>;
550 close $fd;
551 my $group_file = jailed_file("/etc/group");
552 open $fd, '<', $group_file or die "could not open \"$group_file\": $!\n";
553 my $line = 0;
554 my $trimu = sub {
555 my $list = shift;
556 return ':' if $list =~ /^:/;
557 $list =~ s/:.*$//;
558 $list;
560 my $defu = sub {defined($_[0])?$_[0]:""};
561 my @projects = map {/^([^:_\s#][^:\s#]*):([^:]*):(\d{5,}):(.*)$/
562 ? [++$line,$1,$2,$3,&$defu($owners{$1}),&$trimu($4)] : ()} <$fd>;
563 close $fd;
564 @project_list = @projects;
565 $project_list_loaded = 1;
566 @project_list;
569 # Result of Girocco::Project->load or fatal die if that fails, but
570 # if the optional second argument is true and the initial
571 # Girocco::Project->does_exist fails and the first argument names an
572 # existing path, an attempt is made to translate that path into a Girocco
573 # project name and if successful a Girocco::Project->load will be done on that.
574 # Returns undef if passed undef or ""
575 sub get_project {
576 my ($projnameorpath, $tryharder) = @_;
577 (my $projname = $projnameorpath) =~ s/\.git$//i if defined($projnameorpath);
578 defined($projnameorpath) && defined($projname) or return undef;
579 $projname ne "" && Girocco::Project::does_exist($projname, 1) or do {{
580 $projname = undef;
581 last unless $tryharder;
582 # attempt to translate a path into a project
583 my $pn = undef;
584 $pn = get_project_from_dir($projnameorpath) if $projnameorpath ne "";
585 defined($pn) && $pn eq "" and $pn = undef;
586 if (!defined($pn) && $projnameorpath ne "" && -d $projnameorpath) {
587 # see if Git can tell us a --git-dir for the directory
588 my $gd = undef;
589 my $oldcd = getcwd();
590 $oldcd = $1 if defined($oldcd) && $oldcd =~ m{^(/.+)$};
591 if (chdir($projnameorpath)) {
592 $gd = get_git("rev-parse", "--git-dir");
593 chdir($oldcd);
594 defined($gd) and chomp($gd);
596 # could be ugly relative thing
597 defined($gd) && $gd ne "" && substr($gd,0,1) ne "/" and
598 $gd = "$projnameorpath/$gd";
599 # try it again if we got something (could be a "gitdir" file)
600 defined($gd) && $gd ne "" && -e $gd and
601 $pn = get_project_from_dir($gd);
603 defined($pn) && $pn ne "" and $projname = $pn;
605 defined($projname) && $projname ne "" or die "No such project: \"$projnameorpath\"\n";
606 my $project;
607 eval {
608 $project = Girocco::Project->load($projname);
610 } && $project->{loaded} or die "Could not load project \"$projname\"\n";
611 $project;
614 # convenience/self-documenting function that calls get_project
615 # with its first argument and passes true for the second
616 sub get_project_harder {
617 my $projnameorpath = shift;
618 return get_project($projnameorpath, 1);
621 # return true if $enc_passwd is a match for $plain_passwd
622 sub check_passwd_match {
623 my ($enc_passwd, $plain_passwd) = @_;
624 defined($enc_passwd) or $enc_passwd = '';
625 defined($plain_passwd) or $plain_passwd = '';
626 # $enc_passwd may be crypt or crypt_sha1
627 if ($enc_passwd =~ m(^\$sha1\$(\d+)\$([./0-9A-Za-z]{1,64})\$[./0-9A-Za-z]{28}$)) {
628 # It's using sha1-crypt
629 return $enc_passwd eq crypt_sha1($plain_passwd, $2, -(0+$1));
630 } else {
631 # It's using crypt
632 return $enc_passwd eq crypt($plain_passwd, $enc_passwd);
636 sub _which {
637 my $cmd = shift;
638 foreach (File::Spec->path()) {
639 my $p = File::Spec->catfile($_, $cmd);
640 no warnings 'newline';
641 return $p if -x $p && -f _;
643 return undef;
646 # apply maximum nice and ionice
647 my $ionice;
648 sub nice_me {
649 my $niceval = shift;
650 if (defined($niceval) && $niceval =~ /^\d+$/ && 0 + $niceval >= 1) {
651 my $oldval = POSIX::nice(0);
652 POSIX::nice($niceval - $oldval) if $oldval && $niceval > $oldval;
653 } else {
654 POSIX::nice(20);
656 defined($ionice) or $ionice = _which("ionice");
657 defined($ionice) or $ionice = "";
658 if ($ionice ne "") {
659 my $devnullfd = POSIX::open(File::Spec->devnull, O_RDWR);
660 defined($devnullfd) && $devnullfd >= 0 or die "cannot open /dev/null: $!";
661 my ($dupin, $dupout, $duperr);
662 open $dupin, '<&0' or die "cannot dup STDIN_FILENO: $!";
663 open $dupout, '>&1' or die "cannot dup STDOUT_FILENO: $!";
664 open $duperr, '>&2' or die "cannot dup STDERR_FILENO: $!";
665 POSIX::dup2($devnullfd, 0) or die "cannot dup2 STDIN_FILENO: $!";
666 POSIX::dup2($devnullfd, 1) or die "cannot dup2 STDOUT_FILENO: $!";
667 POSIX::dup2($devnullfd, 2) or POSIX::dup2(fileno($duperr), 2), die "cannot dup2 STDERR_FILENO: $!";
668 POSIX::close($devnullfd);
669 system $ionice, "-c", "3", "-p", $$;
670 POSIX::dup2(fileno($duperr), 2) or die "cannot dup2 STDERR_FILENO: $!";
671 POSIX::dup2(fileno($dupout), 1) or die "cannot dup2 STDOUT_FILENO: $!";
672 POSIX::dup2(fileno($dupin), 0) or die "cannot dup2 STDIN_FILENO: $!";
673 close $duperr;
674 close $dupout;
675 close $dupin;
679 # spawn a pager and return the write side of
680 # a pipe to its input. Does not check to see
681 # if STDOUT is a terminal or anything else like
682 # that. Caller is responsible for those checks.
683 # Pager will be chosen as follows:
684 # 1. $ENV{PAGER} if non-empty (eval'd by shell)
685 # 2. less if found in $ENV{PATH}
686 # 3. more if found in $ENV{PATH}
687 # Returns undef if no pager can be found or
688 # setup fails. If return context is wantarray
689 # and pager is created, will return list of
690 # new output handle and pid of child.
691 # As a special case to facilitate paging of STDOUT,
692 # if the first argument is the string "become child",
693 # then, if a pager is created, the child will return
694 # to the caller and the parent will exec the pager!
695 # (The returned pid in that case is the parent's pid
696 # and the parent waits for the child to finish to propagate
697 # its exit status as the final exit value.)
698 sub setup_pager {
699 my $magic = $_[0];
700 defined($magic) && lc($magic) eq "become child" or
701 $magic = 0;
702 my @cmd = ();
703 if (defined($ENV{PAGER}) && $ENV{PAGER} ne "") {
704 my $cmd = $ENV{PAGER};
705 $cmd =~ /^(.+)$/ and $cmd = $1;
706 my $pgbin = undef;
708 no warnings 'newline';
709 -x $cmd && -f $cmd and $pgbin = $cmd;
711 defined($pgbin) && $pgbin ne "" or $pgbin = _which($cmd);
712 if (defined($pgbin) && $pgbin ne "") {
713 $pgbin =~ /^(.+)$/ and push(@cmd, $1);
714 } else {
715 $cmd =~ /\s/ || is_shellish($cmd) or
716 return undef;
717 my $sh = $Girocco::Config::posix_sh_bin;
718 defined($sh) && $sh ne "" or $sh = '/bin/sh';
719 push(@cmd, $sh, "-c", $cmd, $sh);
722 if (!@cmd) {
723 my $pgbin = _which("less");
724 $pgbin or $pgbin = _which("more");
725 defined($pgbin) && $pgbin ne "" or return undef;
726 $pgbin =~ /^(.+)$/ and push(@cmd, $1);
728 local $ENV{LESS} = "-FRX" unless exists($ENV{LESS});
729 local $ENV{LV} = "-c" unless exists($ENV{LV});
730 my $pghnd;
731 use POSIX ();
732 my ($rfd, $wfd) = POSIX::pipe();
733 defined($rfd) && defined($wfd) && $rfd >= 0 && $wfd >= 0 or
734 die "POSIX::pipe failed: $!\n";
735 my $pid = fork();
736 defined($pid) or
737 die "fork failed: $!\n";
738 if (!$magic && !$pid || $magic && $pid) {
739 POSIX::close($wfd);
740 POSIX::dup2($rfd, 0);
741 POSIX::close($rfd);
742 if (!$magic) {
743 exec {$cmd[0]} @cmd or
744 die "exec \"$cmd[0]\" failed: $!\n";
746 my $pagerpid = fork();
747 defined($pagerpid) or
748 die "fork failed: $!\n";
749 if (!$pagerpid) {
750 exec {$cmd[0]} @cmd or
751 die "exec \"$cmd[0]\" failed: $!\n";
753 my $wc = undef;
754 for (;;) {
755 my $child = wait;
756 last if $child == -1;
757 $child == $pid and $wc = $?;
759 defined($wc) or exit 255;
760 my $ec = $wc >> 8;
761 $ec != ($ec & 0xff) and $ec = 255;
762 $ec |= 128 if $wc & 0xff;
763 exit $ec;
765 $magic and $pid = getppid();
766 POSIX::close($rfd);
767 open $pghnd, '>&=', $wfd or
768 die "fdopen of pipe write end failed: $!\n";
769 defined($pid) && defined($pghnd) or return undef;
770 return wantarray ? ($pghnd, $pid) : $pghnd;
773 # return true if any of the known PAGER_IN_USE environment
774 # variables are set
775 sub pager_in_use {
776 return $ENV{GIT_PAGER_IN_USE} || $ENV{TG_PAGER_IN_USE};
779 # possibly set STDOUT to flow through a pager
780 # $_[0]:
781 # defined and false -> return without doing anything
782 # defined and true -> set STDOUT to setup_pager result
783 # undefined:
784 # ! -t STDOUT -> return without doing anything
785 # -t STDOUT:
786 # $_[1] is false -> set STDOUT to setup_pager result
787 # $_[1] is true -> return without doing anything
788 # $[1] means do NOT enable paging by default on -t STDOUT
789 # Most clients can simply call this function without arguments
790 # which will add a pager only if STDOUT is a terminal
791 # If pager_in_use, returns without doing anything.
792 # If pager is activated, sets known pager in use env vars.
793 sub setup_pager_stdout {
794 pager_in_use() and return;
795 my $want_pager = $_[0];
796 defined($want_pager) or
797 $want_pager = (-t STDOUT) ? !$_[1] : 0;
798 return unless $want_pager;
799 my $pghnd = setup_pager('become child');
800 defined($pghnd) or return;
801 if (open(STDOUT, '>&=', $pghnd)) {
802 $ENV{GIT_PAGER_IN_USE} = 1;
803 $ENV{TG_PAGER_IN_USE} = 1;
804 } else {
805 die "failed to set STDOUT to pager: $!\n";