Girocco/CLIUtil.pm

   1 # Girocco::CLIUtil.pm -- Command Line Interface Utility Functions
   2 # Copyright (C) 2016 Kyle J. McKay.  All rights reserved.
   3
   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.
   8 #
   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.
  13 #
  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.
  17
  18 #
  19 ## IMPORTANT
  20 ##
  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!
  24 #
  25
  26 package Girocco::CLIUtil;
  27
  28 use strict;
  29 use warnings;
  30
  31 use base qw(Exporter);
  32 our ($VERSION, @EXPORT, @EXPORT_OK);
  33
  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
  46         );
  47         @EXPORT_OK = qw(
  48                 _parse_options _prompt_rl _prompt_rl_or_die
  49                 check_passwd_match _which
  50         );
  51         *VERSION = \'1.0';
  52 }
  53
  54 use File::Basename;
  55 use File::Spec;
  56 use POSIX qw(:fcntl_h);
  57 use Girocco::Config;
  58 use Girocco::Util;
  59 use Girocco::HashUtil;
  60 use Girocco::CGI;
  61 BEGIN {noFatalsToBrowser}
  62
  63 my $have_rl;
  64 BEGIN {eval{
  65         require Term::ReadLine;
  66         $have_rl = 1;
  67 }}
  68
  69 {
  70         package Girocco::CLIUtil::NoEcho;
  71
  72         sub new {
  73                 my $class = shift; # ignored
  74                 my $self = bless {};
  75                 my $fd = shift || 0;
  76                 $self->{fd} = $fd;
  77                 $self->{ios} = POSIX::Termios->new;
  78                 $self->{ios}->getattr($self->{fd});
  79                 my $noecho = POSIX::Termios->new;
  80                 $noecho->getattr($fd);
  81                 $noecho->setlflag($noecho->getlflag & ~(&POSIX::ECHO));
  82                 $noecho->setattr($fd, &POSIX::TCSANOW);
  83                 $self;
  84         }
  85
  86         sub DESTROY {
  87                 my $self = shift;
  88                 $self->{ios}->setattr($self->{fd}, &POSIX::TCSANOW);
  89         }
  90 }
  91
  92 {
  93         package Girocco::CLIUtil::Progress;
  94
  95         use Scalar::Util qw(looks_like_number);
  96         use Time::HiRes qw(gettimeofday);
  97
  98         sub fractime() { return scalar(gettimeofday) }
  99
 100         my $_init;
 101         BEGIN { $_init = sub {
 102                 my $self = shift;
 103                 my $max = shift;
 104                 looks_like_number($max) && $max >= 0 or $max = 100;
 105                 my $title = shift;
 106                 defined($title) or $title = "";
 107                 $title =~ s/:+$//;
 108                 $title ne "" or $title = "Progress";
 109                 my $lastupd = $self->{lastupd};
 110                 my $shown1 = $self->{shown1};
 111                 looks_like_number($lastupd) or $lastupd = fractime + 2;
 112                 %$self = (
 113                         title => $title,
 114                         max => $max,
 115                         cur => 0,
 116                         len => 0,
 117                         lastupd => $lastupd
 118                 );
 119                 defined($shown1) and $self->{shown1} = $shown1;
 120                 $self;
 121         } }
 122
 123         sub new {
 124                 my $class = shift || __PACKAGE__;
 125                 my $self = bless {}, $class;
 126                 unshift(@_, $self);
 127                 select((select(STDERR),$|=1)[0]);
 128                 select((select(STDOUT),$|=1)[0]);
 129                 return &$_init;
 130         }
 131
 132         sub reset {
 133                 my $self = $_[0];
 134                 $self->clear;
 135                 my $wasvis = $self->{wasvis};
 136                 &$_init;
 137                 $wasvis and $self->show;
 138                 $self;
 139         }
 140
 141         sub val { $_[0]->{cur} }
 142         sub done { $_[0]->{cur} >= $_[0]->{max} }
 143
 144         sub update {
 145                 my $self = shift;
 146                 !$self->{max} and return;
 147                 my $last = $self->{cur};
 148                 my $newcur = shift;
 149                 looks_like_number($newcur) or $newcur = $last + 1;
 150                 $newcur >= $last or $newcur = $last;
 151                 $newcur > $self->{max} and $newcur = $self->{max};
 152                 $self->{cur} = $newcur unless $newcur == $last;
 153                 my $now = fractime;
 154                 if ($self->{shown1} && $newcur > $last && $newcur >= $self->{max} ||
 155                     $now >= $self->{lastupd} + 1) {
 156                         $self->{lastupd} = $now;
 157                         !$self->{len} || $newcur != $last and $self->show;
 158                 }
 159         }
 160
 161         sub show {
 162                 my $self = shift;
 163                 delete $self->{wasvis};
 164                 !$self->{max} and return;
 165                 my $p = int((100 * $self->{cur} / $self->{max}) + 0.5);
 166                 $p > 100 and $p = 100;
 167                 $p == 100 && $self->{cur} < $self->{max} and $p = 99;
 168                 my $status = sprintf("%s: %3d%% (%d/%d)", $self->{title},
 169                         $p, $self->{cur}, $self->{max});
 170                 my $newlen = length($status);
 171                 $self->{len} > $newlen and $status .= " " x ($self->{len} - $newlen);
 172                 printf STDERR "%s\r", $status;
 173                 $self->{len} = $newlen;
 174                 $self->{shown1} = 1;
 175         }
 176
 177         sub clear {
 178                 my $self = shift;
 179                 if ($self->{len}) {
 180                         printf STDERR "%s\r", " " x $self->{len};
 181                         $self->{len} = 0;
 182                         $self->{wasvis} = 1;
 183                 }
 184         }
 185
 186         sub restore {
 187                 my $self = shift;
 188                 $self->{wasvis} and $self->show;
 189         }
 190
 191         sub emitfh {
 192                 my $self = shift;
 193                 my $fh = shift;
 194                 my $msg = join(' ', @_);
 195                 defined($msg) or return;
 196                 chomp $msg;
 197                 $msg ne '' or return;
 198                 $self->clear;
 199                 printf $fh "%s\n", $msg;
 200                 $self->restore;
 201         }
 202
 203         sub emit {
 204                 my $self = shift;
 205                 $self->emitfh(\*STDOUT, @_);
 206         }
 207
 208         sub warn {
 209                 my $self = shift;
 210                 $self->emitfh(\*STDERR, @_);
 211         }
 212
 213         sub DESTROY {
 214                 my $self = shift;
 215                 $self->clear;
 216         }
 217
 218 }# END package Girocco::CLIUtil::Progress
 219
 220 my $diename;
 221 BEGIN {$diename = ""}
 222 sub diename {
 223         my $result = $diename;
 224         $diename = join(" ", @_) if @_;
 225         $result;
 226 }
 227
 228 # Parse Options
 229 #
 230 # Remove any leading options matching the given specs from the @ARGV array and
 231 # store them as indicated.  Parsing stops when an unknown option is encountered,
 232 # "--" is encountered (in which case it's removed) or a non-option is encountered.
 233 # Note that "-" by itself is considered a non-option argument.
 234 #
 235 # Option bundling for single-letter options is NOT supported.
 236 #
 237 # Optional first arg is CODE ref:
 238 #   sub {my ($err, $opt) = @_; ...}
 239 # with $err of '?' meaning $opt is unknown
 240 # with $err of ':' meaning $opt is missing its argument
 241 # $opt is the full option as given on the command line (including leading - etc.)
 242 # the default if omitted dies with an error
 243 # If the sub returns, _parse_options exits immediately with 0
 244 #
 245 # The rest of the arguments form pairs:
 246 #   "spec" => ref
 247 # where ref must be either a SCALAR ref or a CODE ref, if it's neither
 248 # then the "spec" => ref pair is silently ignored.
 249 # "spec" can be:
 250 #   "name"   -- an incrementing flag (matches -name and --name)
 251 #   ":name"  -- an option with a value (matches -name=val and --name=val)
 252 # Using option "--name" matches spec "name" if given otherwise matches spec
 253 # ":name" if given and there's at least one more argument (if not the ':' error
 254 # happens).
 255 # Using option "--name=val" only matches spec ":name" (but "val" can be "").
 256 # For flags, a SCALAR ref is incremented, a CODE ref is called with no arguments.
 257 # For values (":name" specs) a SCALAR ref is assigned the value a CODE ref is
 258 # called with the value as its single argument.
 259 #
 260 # _parse_options returns 1 as long as there were no errors
 261 sub _parse_options {
 262         local $_;
 263         my $failsub = sub {die((($_[0]eq'?')?"unrecognized":"missing argument for")." option \"$_[1]\"\n")};
 264         $failsub = shift if @_ && ref($_[0]) eq "CODE";
 265         my %opts = ();
 266         while (@_ >= 2) {
 267                 if (defined($_[0]) && $_[0] =~ /^:?[^-:\s]/ &&
 268                     defined($_[1]) && (ref($_[1]) eq "SCALAR" || ref($_[1]) eq "CODE")) {
 269                         $opts{$_[0]} = $_[1];
 270                 }
 271                 shift;
 272                 shift;
 273         }
 274         while (@ARGV && $ARGV[0] =~ /^--?[^-:\s]/) {
 275                 my $opt = shift @ARGV;
 276                 my $sopt = $opt;
 277                 $sopt =~ s/^--?//;
 278                 if ($sopt =~ /^([^=]+)=(.*)$/) {
 279                         my ($name, $val) = ($1, $2);
 280                         if ($opts{":$name"}) {
 281                                 ${$opts{":$name"}} = $val if ref($opts{":$name"}) eq "SCALAR";
 282                                 &{$opts{":$name"}}($val) if ref($opts{":$name"}) eq "CODE";
 283                         } else {
 284                                 &$failsub('?', $opt);
 285                                 return 0;
 286                         }
 287                 } elsif ($opts{$sopt}) {
 288                         ++${$opts{$sopt}} if ref($opts{$sopt}) eq "SCALAR";
 289                         &{$opts{$sopt}}() if ref($opts{$sopt}) eq "CODE";
 290                 } elsif ($opts{":$sopt"}) {
 291                         &$failsub(':', $opt),return(0) unless @ARGV;
 292                         my $val = shift @ARGV;
 293                         ${$opts{":$sopt"}} = $val if ref($opts{":$sopt"} eq "SCALAR");
 294                         &{$opts{":$sopt"}}($val) if ref($opts{":$sopt"} eq "CODE");
 295                 } else {
 296                         &$failsub('?', $opt);
 297                         return 0;
 298                 }
 299         }
 300         if (@ARGV && $ARGV[0] eq "--") {
 301                 shift @ARGV;
 302                 return 1;
 303         }
 304         if (@ARGV && $ARGV[0] =~ /^-./) {
 305                 &$failsub('?', $ARGV[0]);
 306                 return 0;
 307         }
 308         return 1;
 309 }
 310
 311 sub recreate_file {
 312         open F, '>', $_[0] or die "failed to create $_[0]: $!\n";
 313         close F;
 314 }
 315
 316 sub is_yes {
 317         my $b = shift;
 318         my $strict = shift;
 319         defined ($b) or $b = "";
 320         return lc($b) eq "yes" || (!$strict && lc($b) eq "y");
 321 }
 322
 323 sub is_no {
 324         my $b = shift;
 325         my $strict = shift;
 326         defined ($b) or $b = "";
 327         return lc($b) eq "no" || (!$strict && lc($b) eq "n");
 328 }
 329
 330 sub is_yesno {
 331         return is_yes(@_) || is_no(@_);
 332 }
 333
 334 my %boolvals;
 335 BEGIN {
 336         %boolvals = (
 337                 true  => 1,
 338                 on    => 1,
 339                 yes   => 1,
 340                 y     => 1,
 341                 1     => 1,
 342
 343                 false => 0,
 344                 off   => 0,
 345                 no    => 0,
 346                 n     => 0,
 347                 0     => 0,
 348         );
 349 }
 350
 351 sub valid_bool {
 352         exists($boolvals{lc($_[0])});
 353 }
 354
 355 sub clean_bool {
 356         my $b = shift || 0;
 357         return $boolvals{lc($b)} || 0;
 358 }
 359
 360 sub _prompt_rl {
 361         my ($norl, $prompt, $default, $promptsfx) = @_;
 362         ! -t STDIN and $norl = 1;
 363         defined($promptsfx) or $promptsfx = ': ';
 364         defined($prompt) or $prompt = '';
 365         my $ds = '';
 366         $ds = " [" . $default . "]" if defined($default);
 367         if ($have_rl && !$norl) {
 368                 my $rl = Term::ReadLine->new(basename($0), \*STDIN, \*STDOUT);
 369                 $rl->ornaments(0);
 370                 $_ = $rl->readline($prompt . $ds . $promptsfx);
 371                 $rl->addhistory($_) if defined($_) && $_ =~ /\S/;
 372         } else {
 373                 print $prompt, $ds, $promptsfx;
 374                 $_ = <STDIN>;
 375         }
 376         return undef unless defined($_);
 377         chomp;
 378         return $_ eq '' && defined($default) ? $default : $_;
 379 }
 380
 381 sub prompt {
 382         return _prompt_rl(undef, @_);
 383 }
 384
 385 sub ynprompt {
 386         my $result;
 387         my @args = @_;
 388         $args[2] = "? " unless defined$args[2];
 389         {
 390                 $result = prompt(@args);
 391                 return undef unless defined($result);
 392                 redo unless is_yesno($result);
 393         }
 394         return clean_bool($result);
 395 }
 396
 397 sub _prompt_rl_or_die {
 398         my $result = _prompt_rl(@_);
 399         unless (defined($result)) {
 400                 my $nm = $diename;
 401                 defined($nm) or $nm = "";
 402                 $nm eq "" or $nm .= " ";
 403                 die "\n${nm}aborted\n";
 404         }
 405         $result;
 406 }
 407
 408 sub prompt_or_die {
 409         return _prompt_rl_or_die(undef, @_);
 410 }
 411
 412 sub ynprompt_or_die {
 413         my $result = ynprompt(@_);
 414         unless (defined($result)) {
 415                 my $nm = $diename;
 416                 defined($nm) or $nm = "";
 417                 $nm eq "" or $nm .= " ";
 418                 die "\n${nm}aborted\n";
 419         }
 420         $result;
 421 }
 422
 423 sub prompt_noecho {
 424         my $ne = Girocco::CLIUtil::NoEcho->new;
 425         _prompt_rl(1, @_);
 426 }
 427
 428 sub prompt_noecho_or_die {
 429         my $ne = Girocco::CLIUtil::NoEcho->new;
 430         _prompt_rl_or_die(1, @_);
 431 }
 432
 433 sub prompt_noecho_nl {
 434         my $result = prompt_noecho(@_);
 435         print "\n";
 436         $result;
 437 }
 438
 439 sub prompt_noecho_nl_or_die {
 440         my $result = prompt_noecho_or_die(@_);
 441         print "\n";
 442         $result;
 443 }
 444
 445 sub yes_to_continue {
 446         return !!ynprompt(($_[0]||"Continue (enter \"yes\" to continue)"), "no");
 447 }
 448
 449 sub yes_to_continue_or_die {
 450         unless (ynprompt_or_die(($_[0]||"Continue (enter \"yes\" to continue)"), "no")) {
 451                 my $nm = $diename;
 452                 defined($nm) or $nm = "";
 453                 $nm .= " " if $nm ne "";
 454                 die "${nm}aborted\n";
 455         }
 456         return 1;
 457 }
 458
 459 my @user_list;
 460 my $user_list_loaded;
 461 my @full_user_list;
 462 my $full_user_list_loaded;
 463
 464 # If single argument is true, return ALL passwd entries not just "...@..." ones
 465 sub _get_all_users_internal {
 466         my $full = shift || 0;
 467         if ($full) {
 468                 return @full_user_list if $full_user_list_loaded;
 469         } else {
 470                 return @user_list if $user_list_loaded;
 471         }
 472         my $passwd_file = jailed_file("/etc/passwd");
 473         open my $fd, '<', $passwd_file or die "could not open \"$passwd_file\": $!\n";
 474         my $line = 0;
 475         my @users;
 476         if ($full) {
 477                 @users = map {/^([^:\s#][^:\s]*):[^:]*:(-?\d+):(-?\d+)(:|$)/
 478                          ? [++$line,split(':',$_,-1)] : ()} <$fd>;
 479         } else {
 480                 @users = map {/^([^:_\s#][^:\s#]*):[^:]+:(\d{5,}):(\d+):([^:,][^:]*)/
 481                          ? [++$line,$1,$2,$3,split(',',$4)] : ()} <$fd>;
 482         }
 483         close $fd;
 484         if ($full) {
 485                 $$_[5] = [split(',', $$_[5])] foreach @users;
 486                 @full_user_list = @users;
 487                 $full_user_list_loaded = 1;
 488         } else {
 489                 @users = grep({$$_[4] =~ /\@/} @users);
 490                 @user_list = @users;
 491                 $user_list_loaded = 1;
 492         }
 493         @users;
 494 }
 495
 496 # Return array of arrayref where each arrayref has:
 497 #   [0] = ordering ordinal from $chroot/etc/passwd
 498 #   [1] = user name
 499 #   [2] = user id number
 500 #   [3] = user group number
 501 #   [4] = user email
 502 #   [5] = user UUID (text as 8x-4x-4x-4x-12x) or undef if none
 503 #   [6] = user creation date as YYYYMMDD_HHMMSS (UTC) or undef if none
 504 sub get_all_users { return _get_all_users_internal; }
 505
 506 # Return array of arrayref where each arrayref has:
 507 #   [0] = ordering ordinal from $chroot/etc/passwd
 508 #   [1] = user name
 509 #   [2] = user password field (usually "x")
 510 #   [3] = user id number
 511 #   [4] = user group number
 512 #   [5] = [info fields] from passwd line (usually email,uuid,creation)
 513 #   [6] = home dir field
 514 #   [7] = shell field
 515 #   [...] possibly more, but [7] is usually max
 516 sub get_full_users { return _get_all_users_internal(1); }
 517
 518 # Result of Girocco::User->load or fatal die if that fails
 519 # Returns undef if passed undef or ""
 520 sub get_user {
 521         my $username = shift;
 522         defined($username) && $username ne "" or return undef;
 523         Girocco::User::does_exist($username, 1) or die "No such user: \"$username\"\n";
 524         my $user;
 525         eval {
 526                 $user = Girocco::User->load($username);
 527                 1;
 528         } && $user->{uid} or die "Could not load user \"$username\"\n";
 529         $user;
 530 }
 531
 532 my @project_list;
 533 my $project_list_loaded;
 534
 535 # Return array of arrayref where each arrayref has:
 536 #   [0] = ordering ordinal from $chroot/etc/group
 537 #   [1] = group name
 538 #   [2] = group password hash
 539 #   [3] = group id number
 540 #   [4] = owner from gitproj.list
 541 #   [5] = list of comma-separated push user names (can be "") or ":" if mirror
 542 sub get_all_projects {
 543         return @project_list if $project_list_loaded;
 544         my $fd;
 545         my $projlist_file = $Girocco::Config::projlist_cache_dir."/gitproj.list";
 546         open $fd, '<', $projlist_file or die "could not open \"$projlist_file\": $!\n";
 547         my $chomper = sub {chomp(my $x = shift); $x;};
 548         my %owners = map {(split(/\s+/, &$chomper($_), 3))[0,2]} <$fd>;
 549         close $fd;
 550         my $group_file = jailed_file("/etc/group");
 551         open $fd, '<', $group_file or die "could not open \"$group_file\": $!\n";
 552         my $line = 0;
 553         my $trimu = sub {
 554                 my $list = shift;
 555                 return ':' if $list =~ /^:/;
 556                 $list =~ s/:.*$//;
 557                 $list;
 558         };
 559         my $defu = sub {defined($_[0])?$_[0]:""};
 560         my @projects = map {/^([^:_\s#][^:\s#]*):([^:]*):(\d{5,}):(.*)$/
 561                             ? [++$line,$1,$2,$3,&$defu($owners{$1}),&$trimu($4)] : ()} <$fd>;
 562         close $fd;
 563         @project_list = @projects;
 564         $project_list_loaded = 1;
 565         @project_list;
 566 }
 567
 568 # Result of Girocco::Project->load or fatal die if that fails
 569 # Returns undef if passed undef or ""
 570 sub get_project {
 571         my $projname = shift;
 572         $projname =~ s/\.git$//i if defined($projname);
 573         defined($projname) && $projname ne "" or return undef;
 574         Girocco::Project::does_exist($projname, 1) or die "No such project: \"$projname\"\n";
 575         my $project;
 576         eval {
 577                 $project = Girocco::Project->load($projname);
 578                 1;
 579         } && $project->{loaded} or die "Could not load project \"$projname\"\n";
 580         $project;
 581 }
 582
 583 # return true if $enc_passwd is a match for $plain_passwd
 584 sub check_passwd_match {
 585         my ($enc_passwd, $plain_passwd) = @_;
 586         defined($enc_passwd) or $enc_passwd = '';
 587         defined($plain_passwd) or $plain_passwd = '';
 588         # $enc_passwd may be crypt or crypt_sha1
 589         if ($enc_passwd =~ m(^\$sha1\$(\d+)\$([./0-9A-Za-z]{1,64})\$[./0-9A-Za-z]{28}$)) {
 590                 # It's using sha1-crypt
 591                 return $enc_passwd eq crypt_sha1($plain_passwd, $2, -(0+$1));
 592         } else {
 593                 # It's using crypt
 594                 return $enc_passwd eq crypt($plain_passwd, $enc_passwd);
 595         }
 596 };
 597
 598 sub _which {
 599         my $cmd = shift;
 600         foreach (File::Spec->path()) {
 601                 my $p = File::Spec->catfile($_, $cmd);
 602                 no warnings 'newline';
 603                 return $p if -x $p && -f _;
 604         }
 605         return undef;
 606 }
 607
 608 # apply maximum nice and ionice
 609 my $ionice;
 610 sub nice_me {
 611         my $niceval = shift;
 612         if (defined($niceval) && $niceval =~ /^\d+$/ && 0 + $niceval >= 1) {
 613                 my $oldval = POSIX::nice(0);
 614                 POSIX::nice($niceval - $oldval) if $oldval && $niceval > $oldval;
 615         } else {
 616                 POSIX::nice(20);
 617         }
 618         defined($ionice) or $ionice = _which("ionice");
 619         defined($ionice) or $ionice = "";
 620         if ($ionice ne "") {
 621                 my $devnullfd = POSIX::open(File::Spec->devnull, O_RDWR);
 622                 defined($devnullfd) && $devnullfd >= 0 or die "cannot open /dev/null: $!";
 623                 my ($dupin, $dupout, $duperr);
 624                 open $dupin, '<&0' or die "cannot dup STDIN_FILENO: $!";
 625                 open $dupout, '>&1' or die "cannot dup STDOUT_FILENO: $!";
 626                 open $duperr, '>&2' or die "cannot dup STDERR_FILENO: $!";
 627                 POSIX::dup2($devnullfd, 0) or die "cannot dup2 STDIN_FILENO: $!";
 628                 POSIX::dup2($devnullfd, 1) or die "cannot dup2 STDOUT_FILENO: $!";
 629                 POSIX::dup2($devnullfd, 2) or POSIX::dup2(fileno($duperr), 2), die "cannot dup2 STDERR_FILENO: $!";
 630                 POSIX::close($devnullfd);
 631                 system $ionice, "-c", "3", "-p", $$;
 632                 POSIX::dup2(fileno($duperr), 2) or die "cannot dup2 STDERR_FILENO: $!";
 633                 POSIX::dup2(fileno($dupout), 1) or die "cannot dup2 STDOUT_FILENO: $!";
 634                 POSIX::dup2(fileno($dupin), 0) or die "cannot dup2 STDIN_FILENO: $!";
 635                 close $duperr;
 636                 close $dupout;
 637                 close $dupin;
 638         }
 639 }
 640
 641 # spawn a pager and return the write side of
 642 # a pipe to its input.  Does not check to see
 643 # if STDOUT is a terminal or anything else like
 644 # that.  Caller is responsible for those checks.
 645 # Pager will be chosen as follows:
 646 #   1. $ENV{PAGER} if non-empty (eval'd by shell)
 647 #   2. less if found in $ENV{PATH}
 648 #   3. more if found in $ENV{PATH}
 649 # Returns undef if no pager can be found or
 650 # setup fails.  If return context is wantarray
 651 # and pager is created, will return list of
 652 # new output handle and pid of child.
 653 # As a special case to facilitate paging of STDOUT,
 654 # if the first argument is the string "become child",
 655 # then, if a pager is created, the child will return
 656 # to the caller and the parent will exec the pager!
 657 # (The returned pid in that case is the parent's pid
 658 # and the parent waits for the child to finish to propagate
 659 # its exit status as the final exit value.)
 660 sub setup_pager {
 661         my $magic = $_[0];
 662         defined($magic) && lc($magic) eq "become child" or
 663                 $magic = 0;
 664         my @cmd = ();
 665         if (defined($ENV{PAGER}) && $ENV{PAGER} ne "") {
 666                 my $cmd = $ENV{PAGER};
 667                 $cmd =~ /^(.+)$/ and $cmd = $1;
 668                 my $pgbin = undef;
 669                 {
 670                         no warnings 'newline';
 671                         -x $cmd && -f $cmd and $pgbin = $cmd;
 672                 }
 673                 defined($pgbin) && $pgbin ne "" or $pgbin = _which($cmd);
 674                 if (defined($pgbin) && $pgbin ne "") {
 675                         $pgbin =~ /^(.+)$/ and push(@cmd, $1);
 676                 } else {
 677                         $cmd =~ /\s/ || is_shellish($cmd) or
 678                                 return undef;
 679                         my $sh = $Girocco::Config::posix_sh_bin;
 680                         defined($sh) && $sh ne "" or $sh = '/bin/sh';
 681                         push(@cmd, $sh, "-c", $cmd, $sh);
 682                 }
 683         }
 684         if (!@cmd) {
 685                 my $pgbin = _which("less");
 686                 $pgbin or $pgbin = _which("more");
 687                 defined($pgbin) && $pgbin ne "" or return undef;
 688                 $pgbin =~ /^(.+)$/ and push(@cmd, $1);
 689         }
 690         local $ENV{LESS} = "-FRX" unless exists($ENV{LESS});
 691         local $ENV{LV} = "-c" unless exists($ENV{LV});
 692         my $pghnd;
 693         use POSIX ();
 694         my ($rfd, $wfd) = POSIX::pipe();
 695         defined($rfd) && defined($wfd) && $rfd >= 0 && $wfd >= 0 or
 696                 die "POSIX::pipe failed: $!\n";
 697         my $pid = fork();
 698         defined($pid) or
 699                 die "fork failed: $!\n";
 700         if (!$magic && !$pid || $magic && $pid) {
 701                 POSIX::close($wfd);
 702                 POSIX::dup2($rfd, 0);
 703                 POSIX::close($rfd);
 704                 if (!$magic) {
 705                         exec {$cmd[0]} @cmd or
 706                                 die "exec \"$cmd[0]\" failed: $!\n";
 707                 }
 708                 my $pagerpid = fork();
 709                 defined($pagerpid) or
 710                         die "fork failed: $!\n";
 711                 if (!$pagerpid) {
 712                         exec {$cmd[0]} @cmd or
 713                                 die "exec \"$cmd[0]\" failed: $!\n";
 714                 }
 715                 my $wc = undef;
 716                 for (;;) {
 717                         my $child = wait;
 718                         last if $child == -1;
 719                         $child == $pid and $wc = $?;
 720                 }
 721                 defined($wc) or exit 255;
 722                 my $ec = $wc >> 8;
 723                 $ec != ($ec & 0xff) and $ec = 255;
 724                 $ec |= 128 if $wc & 0xff;
 725                 exit $ec;
 726         }
 727         $magic and $pid = getppid();
 728         POSIX::close($rfd);
 729         open $pghnd, '>&=', $wfd or
 730                         die "fdopen of pipe write end failed: $!\n";
 731         defined($pid) && defined($pghnd) or return undef;
 732         return wantarray ? ($pghnd, $pid) : $pghnd;
 733 }
 734
 735 # return true if any of the known PAGER_IN_USE environment
 736 # variables are set
 737 sub pager_in_use {
 738         return $ENV{GIT_PAGER_IN_USE} || $ENV{TG_PAGER_IN_USE};
 739 }
 740
 741 # possibly set STDOUT to flow through a pager
 742 # $_[0]:
 743 #   defined and false  -> return without doing anything
 744 #   defined and true   -> set STDOUT to setup_pager result
 745 #   undefined:
 746 #     ! -t STDOUT      -> return without doing anything
 747 #     -t STDOUT:
 748 #       $_[1] is false -> set STDOUT to setup_pager result
 749 #       $_[1] is true  -> return without doing anything
 750 # $[1] means do NOT enable paging by default on -t STDOUT
 751 # Most clients can simply call this function without arguments
 752 # which will add a pager only if STDOUT is a terminal
 753 # If pager_in_use, returns without doing anything.
 754 # If pager is activated, sets known pager in use env vars.
 755 sub setup_pager_stdout {
 756         pager_in_use() and return;
 757         my $want_pager = $_[0];
 758         defined($want_pager) or
 759                 $want_pager = (-t STDOUT) ? !$_[1] : 0;
 760         return unless $want_pager;
 761         my $pghnd = setup_pager('become child');
 762         defined($pghnd) or return;
 763         if (open(STDOUT, '>&=', $pghnd)) {
 764                 $ENV{GIT_PAGER_IN_USE} = 1;
 765                 $ENV{TG_PAGER_IN_USE} = 1;
 766         } else {
 767                 die "failed to set STDOUT to pager: $!\n";
 768         }
 769 }
 770
 771 1;