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, $msg) = @_;
 194                 defined($msg) or return;
 195                 chomp $msg;
 196                 $msg ne "" or return;
 197                 $self->clear;
 198                 printf $fh "%s\n", $msg;
 199                 $self->restore;
 200         }
 201
 202         sub emit {
 203                 my $self = shift;
 204                 $self->emitfh(\*STDOUT, @_);
 205         }
 206
 207         sub warn {
 208                 my $self = shift;
 209                 $self->emitfh(\*STDERR, @_);
 210         }
 211
 212         sub DESTROY {
 213                 my $self = shift;
 214                 $self->clear;
 215         }
 216
 217 }# END package Girocco::CLIUtil::Progress
 218
 219 my $diename;
 220 BEGIN {$diename = ""}
 221 sub diename {
 222         my $result = $diename;
 223         $diename = join(" ", @_) if @_;
 224         $result;
 225 }
 226
 227 # Parse Options
 228 #
 229 # Remove any leading options matching the given specs from the @ARGV array and
 230 # store them as indicated.  Parsing stops when an unknown option is encountered,
 231 # "--" is encountered (in which case it's removed) or a non-option is encountered.
 232 # Note that "-" by itself is considered a non-option argument.
 233 #
 234 # Option bundling for single-letter options is NOT supported.
 235 #
 236 # Optional first arg is CODE ref:
 237 #   sub {my ($err, $opt) = @_; ...}
 238 # with $err of '?' meaning $opt is unknown
 239 # with $err of ':' meaning $opt is missing its argument
 240 # $opt is the full option as given on the command line (including leading - etc.)
 241 # the default if omitted dies with an error
 242 # If the sub returns, _parse_options exits immediately with 0
 243 #
 244 # The rest of the arguments form pairs:
 245 #   "spec" => ref
 246 # where ref must be either a SCALAR ref or a CODE ref, if it's neither
 247 # then the "spec" => ref pair is silently ignored.
 248 # "spec" can be:
 249 #   "name"   -- an incrementing flag (matches -name and --name)
 250 #   ":name"  -- an option with a value (matches -name=val and --name=val)
 251 # Using option "--name" matches spec "name" if given otherwise matches spec
 252 # ":name" if given and there's at least one more argument (if not the ':' error
 253 # happens).
 254 # Using option "--name=val" only matches spec ":name" (but "val" can be "").
 255 # For flags, a SCALAR ref is incremented, a CODE ref is called with no arguments.
 256 # For values (":name" specs) a SCALAR ref is assigned the value a CODE ref is
 257 # called with the value as its single argument.
 258 #
 259 # _parse_options returns 1 as long as there were no errors
 260 sub _parse_options {
 261         local $_;
 262         my $failsub = sub {die((($_[0]eq'?')?"unrecognized":"missing argument for")." option \"$_[1]\"\n")};
 263         $failsub = shift if @_ && ref($_[0]) eq "CODE";
 264         my %opts = ();
 265         while (@_ >= 2) {
 266                 if (defined($_[0]) && $_[0] =~ /^:?[^-:\s]/ &&
 267                     defined($_[1]) && (ref($_[1]) eq "SCALAR" || ref($_[1]) eq "CODE")) {
 268                         $opts{$_[0]} = $_[1];
 269                 }
 270                 shift;
 271                 shift;
 272         }
 273         while (@ARGV && $ARGV[0] =~ /^--?[^-:\s]/) {
 274                 my $opt = shift @ARGV;
 275                 my $sopt = $opt;
 276                 $sopt =~ s/^--?//;
 277                 if ($sopt =~ /^([^=]+)=(.*)$/) {
 278                         my ($name, $val) = ($1, $2);
 279                         if ($opts{":$name"}) {
 280                                 ${$opts{":$name"}} = $val if ref($opts{":$name"}) eq "SCALAR";
 281                                 &{$opts{":$name"}}($val) if ref($opts{":$name"}) eq "CODE";
 282                         } else {
 283                                 &$failsub('?', $opt);
 284                                 return 0;
 285                         }
 286                 } elsif ($opts{$sopt}) {
 287                         ++${$opts{$sopt}} if ref($opts{$sopt}) eq "SCALAR";
 288                         &{$opts{$sopt}}() if ref($opts{$sopt}) eq "CODE";
 289                 } elsif ($opts{":$sopt"}) {
 290                         &$failsub(':', $opt),return(0) unless @ARGV;
 291                         my $val = shift @ARGV;
 292                         ${$opts{":$sopt"}} = $val if ref($opts{":$sopt"} eq "SCALAR");
 293                         &{$opts{":$sopt"}}($val) if ref($opts{":$sopt"} eq "CODE");
 294                 } else {
 295                         &$failsub('?', $opt);
 296                         return 0;
 297                 }
 298         }
 299         if (@ARGV && $ARGV[0] eq "--") {
 300                 shift @ARGV;
 301                 return 1;
 302         }
 303         if (@ARGV && $ARGV[0] =~ /^-./) {
 304                 &$failsub('?', $ARGV[0]);
 305                 return 0;
 306         }
 307         return 1;
 308 }
 309
 310 sub recreate_file {
 311         open F, '>', $_[0] or die "failed to create $_[0]: $!\n";
 312         close F;
 313 }
 314
 315 sub is_yes {
 316         my $b = shift;
 317         my $strict = shift;
 318         defined ($b) or $b = "";
 319         return lc($b) eq "yes" || (!$strict && lc($b) eq "y");
 320 }
 321
 322 sub is_no {
 323         my $b = shift;
 324         my $strict = shift;
 325         defined ($b) or $b = "";
 326         return lc($b) eq "no" || (!$strict && lc($b) eq "n");
 327 }
 328
 329 sub is_yesno {
 330         return is_yes(@_) || is_no(@_);
 331 }
 332
 333 my %boolvals;
 334 BEGIN {
 335         %boolvals = (
 336                 true  => 1,
 337                 on    => 1,
 338                 yes   => 1,
 339                 y     => 1,
 340                 1     => 1,
 341
 342                 false => 0,
 343                 off   => 0,
 344                 no    => 0,
 345                 n     => 0,
 346                 0     => 0,
 347         );
 348 }
 349
 350 sub valid_bool {
 351         exists($boolvals{lc($_[0])});
 352 }
 353
 354 sub clean_bool {
 355         my $b = shift || 0;
 356         return $boolvals{lc($b)} || 0;
 357 }
 358
 359 sub _prompt_rl {
 360         my ($norl, $prompt, $default, $promptsfx) = @_;
 361         ! -t STDIN and $norl = 1;
 362         defined($promptsfx) or $promptsfx = ': ';
 363         defined($prompt) or $prompt = '';
 364         my $ds = '';
 365         $ds = " [" . $default . "]" if defined($default);
 366         if ($have_rl && !$norl) {
 367                 my $rl = Term::ReadLine->new(basename($0), \*STDIN, \*STDOUT);
 368                 $rl->ornaments(0);
 369                 $_ = $rl->readline($prompt . $ds . $promptsfx);
 370                 $rl->addhistory($_) if defined($_) && $_ =~ /\S/;
 371         } else {
 372                 print $prompt, $ds, $promptsfx;
 373                 $_ = <STDIN>;
 374         }
 375         return undef unless defined($_);
 376         chomp;
 377         return $_ eq '' && defined($default) ? $default : $_;
 378 }
 379
 380 sub prompt {
 381         return _prompt_rl(undef, @_);
 382 }
 383
 384 sub ynprompt {
 385         my $result;
 386         my @args = @_;
 387         $args[2] = "? " unless defined$args[2];
 388         {
 389                 $result = prompt(@args);
 390                 return undef unless defined($result);
 391                 redo unless is_yesno($result);
 392         }
 393         return clean_bool($result);
 394 }
 395
 396 sub _prompt_rl_or_die {
 397         my $result = _prompt_rl(@_);
 398         unless (defined($result)) {
 399                 my $nm = $diename;
 400                 defined($nm) or $nm = "";
 401                 $nm eq "" or $nm .= " ";
 402                 die "\n${nm}aborted\n";
 403         }
 404         $result;
 405 }
 406
 407 sub prompt_or_die {
 408         return _prompt_rl_or_die(undef, @_);
 409 }
 410
 411 sub ynprompt_or_die {
 412         my $result = ynprompt(@_);
 413         unless (defined($result)) {
 414                 my $nm = $diename;
 415                 defined($nm) or $nm = "";
 416                 $nm eq "" or $nm .= " ";
 417                 die "\n${nm}aborted\n";
 418         }
 419         $result;
 420 }
 421
 422 sub prompt_noecho {
 423         my $ne = Girocco::CLIUtil::NoEcho->new;
 424         _prompt_rl(1, @_);
 425 }
 426
 427 sub prompt_noecho_or_die {
 428         my $ne = Girocco::CLIUtil::NoEcho->new;
 429         _prompt_rl_or_die(1, @_);
 430 }
 431
 432 sub prompt_noecho_nl {
 433         my $result = prompt_noecho(@_);
 434         print "\n";
 435         $result;
 436 }
 437
 438 sub prompt_noecho_nl_or_die {
 439         my $result = prompt_noecho_or_die(@_);
 440         print "\n";
 441         $result;
 442 }
 443
 444 sub yes_to_continue {
 445         return !!ynprompt(($_[0]||"Continue (enter \"yes\" to continue)"), "no");
 446 }
 447
 448 sub yes_to_continue_or_die {
 449         unless (ynprompt_or_die(($_[0]||"Continue (enter \"yes\" to continue)"), "no")) {
 450                 my $nm = $diename;
 451                 defined($nm) or $nm = "";
 452                 $nm .= " " if $nm ne "";
 453                 die "${nm}aborted\n";
 454         }
 455         return 1;
 456 }
 457
 458 my @user_list;
 459 my $user_list_loaded;
 460 my @full_user_list;
 461 my $full_user_list_loaded;
 462
 463 # If single argument is true, return ALL passwd entries not just "...@..." ones
 464 sub _get_all_users_internal {
 465         my $full = shift || 0;
 466         if ($full) {
 467                 return @full_user_list if $full_user_list_loaded;
 468         } else {
 469                 return @user_list if $user_list_loaded;
 470         }
 471         my $passwd_file = jailed_file("/etc/passwd");
 472         open my $fd, '<', $passwd_file or die "could not open \"$passwd_file\": $!\n";
 473         my $line = 0;
 474         my @users;
 475         if ($full) {
 476                 @users = map {/^([^:\s#][^:\s]*):[^:]*:(-?\d+):(-?\d+)(:|$)/
 477                          ? [++$line,split(':',$_,-1)] : ()} <$fd>;
 478         } else {
 479                 @users = map {/^([^:_\s#][^:\s#]*):[^:]+:(\d{5,}):(\d+):([^:,][^:]*)/
 480                          ? [++$line,$1,$2,$3,split(',',$4)] : ()} <$fd>;
 481         }
 482         close $fd;
 483         if ($full) {
 484                 $$_[5] = [split(',', $$_[5])] foreach @users;
 485                 @full_user_list = @users;
 486                 $full_user_list_loaded = 1;
 487         } else {
 488                 @users = grep({$$_[4] =~ /\@/} @users);
 489                 @user_list = @users;
 490                 $user_list_loaded = 1;
 491         }
 492         @users;
 493 }
 494
 495 # Return array of arrayref where each arrayref has:
 496 #   [0] = ordering ordinal from $chroot/etc/passwd
 497 #   [1] = user name
 498 #   [2] = user id number
 499 #   [3] = user group number
 500 #   [4] = user email
 501 #   [5] = user UUID (text as 8x-4x-4x-4x-12x) or undef if none
 502 #   [6] = user creation date as YYYYMMDD_HHMMSS (UTC) or undef if none
 503 sub get_all_users { return _get_all_users_internal; }
 504
 505 # Return array of arrayref where each arrayref has:
 506 #   [0] = ordering ordinal from $chroot/etc/passwd
 507 #   [1] = user name
 508 #   [2] = user password field (usually "x")
 509 #   [3] = user id number
 510 #   [4] = user group number
 511 #   [5] = [info fields] from passwd line (usually email,uuid,creation)
 512 #   [6] = home dir field
 513 #   [7] = shell field
 514 #   [...] possibly more, but [7] is usually max
 515 sub get_full_users { return _get_all_users_internal(1); }
 516
 517 # Result of Girocco::User->load or fatal die if that fails
 518 # Returns undef if passed undef or ""
 519 sub get_user {
 520         my $username = shift;
 521         defined($username) && $username ne "" or return undef;
 522         Girocco::User::does_exist($username, 1) or die "No such user: \"$username\"\n";
 523         my $user;
 524         eval {
 525                 $user = Girocco::User->load($username);
 526                 1;
 527         } && $user->{uid} or die "Could not load user \"$username\"\n";
 528         $user;
 529 }
 530
 531 my @project_list;
 532 my $project_list_loaded;
 533
 534 # Return array of arrayref where each arrayref has:
 535 #   [0] = ordering ordinal from $chroot/etc/group
 536 #   [1] = group name
 537 #   [2] = group password hash
 538 #   [3] = group id number
 539 #   [4] = owner from gitproj.list
 540 #   [5] = list of comma-separated push user names (can be "") or ":" if mirror
 541 sub get_all_projects {
 542         return @project_list if $project_list_loaded;
 543         my $fd;
 544         my $projlist_file = $Girocco::Config::projlist_cache_dir."/gitproj.list";
 545         open $fd, '<', $projlist_file or die "could not open \"$projlist_file\": $!\n";
 546         my $chomper = sub {chomp(my $x = shift); $x;};
 547         my %owners = map {(split(/\s+/, &$chomper($_), 3))[0,2]} <$fd>;
 548         close $fd;
 549         my $group_file = jailed_file("/etc/group");
 550         open $fd, '<', $group_file or die "could not open \"$group_file\": $!\n";
 551         my $line = 0;
 552         my $trimu = sub {
 553                 my $list = shift;
 554                 return ':' if $list =~ /^:/;
 555                 $list =~ s/:.*$//;
 556                 $list;
 557         };
 558         my $defu = sub {defined($_[0])?$_[0]:""};
 559         my @projects = map {/^([^:_\s#][^:\s#]*):([^:]*):(\d{5,}):(.*)$/
 560                             ? [++$line,$1,$2,$3,&$defu($owners{$1}),&$trimu($4)] : ()} <$fd>;
 561         close $fd;
 562         @project_list = @projects;
 563         $project_list_loaded = 1;
 564         @project_list;
 565 }
 566
 567 # Result of Girocco::Project->load or fatal die if that fails
 568 # Returns undef if passed undef or ""
 569 sub get_project {
 570         my $projname = shift;
 571         $projname =~ s/\.git$//i if defined($projname);
 572         defined($projname) && $projname ne "" or return undef;
 573         Girocco::Project::does_exist($projname, 1) or die "No such project: \"$projname\"\n";
 574         my $project;
 575         eval {
 576                 $project = Girocco::Project->load($projname);
 577                 1;
 578         } && $project->{loaded} or die "Could not load project \"$projname\"\n";
 579         $project;
 580 }
 581
 582 # return true if $enc_passwd is a match for $plain_passwd
 583 sub check_passwd_match {
 584         my ($enc_passwd, $plain_passwd) = @_;
 585         defined($enc_passwd) or $enc_passwd = '';
 586         defined($plain_passwd) or $plain_passwd = '';
 587         # $enc_passwd may be crypt or crypt_sha1
 588         if ($enc_passwd =~ m(^\$sha1\$(\d+)\$([./0-9A-Za-z]{1,64})\$[./0-9A-Za-z]{28}$)) {
 589                 # It's using sha1-crypt
 590                 return $enc_passwd eq crypt_sha1($plain_passwd, $2, -(0+$1));
 591         } else {
 592                 # It's using crypt
 593                 return $enc_passwd eq crypt($plain_passwd, $enc_passwd);
 594         }
 595 };
 596
 597 sub _which {
 598         my $cmd = shift;
 599         foreach (File::Spec->path()) {
 600                 my $p = File::Spec->catfile($_, $cmd);
 601                 no warnings 'newline';
 602                 return $p if -x $p && -f _;
 603         }
 604         return undef;
 605 }
 606
 607 # apply maximum nice and ionice
 608 my $ionice;
 609 sub nice_me {
 610         my $niceval = shift;
 611         if (defined($niceval) && $niceval =~ /^\d+$/ && 0 + $niceval >= 1) {
 612                 my $oldval = POSIX::nice(0);
 613                 POSIX::nice($niceval - $oldval) if $oldval && $niceval > $oldval;
 614         } else {
 615                 POSIX::nice(20);
 616         }
 617         defined($ionice) or $ionice = _which("ionice");
 618         defined($ionice) or $ionice = "";
 619         if ($ionice ne "") {
 620                 my $devnullfd = POSIX::open(File::Spec->devnull, O_RDWR);
 621                 defined($devnullfd) && $devnullfd >= 0 or die "cannot open /dev/null: $!";
 622                 my ($dupin, $dupout, $duperr);
 623                 open $dupin, '<&0' or die "cannot dup STDIN_FILENO: $!";
 624                 open $dupout, '>&1' or die "cannot dup STDOUT_FILENO: $!";
 625                 open $duperr, '>&2' or die "cannot dup STDERR_FILENO: $!";
 626                 POSIX::dup2($devnullfd, 0) or die "cannot dup2 STDIN_FILENO: $!";
 627                 POSIX::dup2($devnullfd, 1) or die "cannot dup2 STDOUT_FILENO: $!";
 628                 POSIX::dup2($devnullfd, 2) or POSIX::dup2(fileno($duperr), 2), die "cannot dup2 STDERR_FILENO: $!";
 629                 POSIX::close($devnullfd);
 630                 system $ionice, "-c", "3", "-p", $$;
 631                 POSIX::dup2(fileno($duperr), 2) or die "cannot dup2 STDERR_FILENO: $!";
 632                 POSIX::dup2(fileno($dupout), 1) or die "cannot dup2 STDOUT_FILENO: $!";
 633                 POSIX::dup2(fileno($dupin), 0) or die "cannot dup2 STDIN_FILENO: $!";
 634                 close $duperr;
 635                 close $dupout;
 636                 close $dupin;
 637         }
 638 }
 639
 640 # spawn a pager and return the write side of
 641 # a pipe to its input.  Does not check to see
 642 # if STDOUT is a terminal or anything else like
 643 # that.  Caller is responsible for those checks.
 644 # Pager will be chosen as follows:
 645 #   1. $ENV{PAGER} if non-empty (eval'd by shell)
 646 #   2. less if found in $ENV{PATH}
 647 #   3. more if found in $ENV{PATH}
 648 # Returns undef if no pager can be found or
 649 # setup fails.  If return context is wantarray
 650 # and pager is created, will return list of
 651 # new output handle and pid of child.
 652 # As a special case to facilitate paging of STDOUT,
 653 # if the first argument is the string "become child",
 654 # then, if a pager is created, the child will return
 655 # to the caller and the parent will exec the pager!
 656 # (The returned pid in that case is the parent's pid.)
 657 sub setup_pager {
 658         my $magic = $_[0];
 659         defined($magic) && lc($magic) eq "become child" or
 660                 $magic = 0;
 661         my @cmd = ();
 662         if (defined($ENV{PAGER}) && $ENV{PAGER} ne "") {
 663                 my $cmd = $ENV{PAGER};
 664                 $cmd =~ /^(.+)$/ and $cmd = $1;
 665                 my $pgbin = undef;
 666                 {
 667                         no warnings 'newline';
 668                         -x $cmd && -f $cmd and $pgbin = $cmd;
 669                 }
 670                 defined($pgbin) && $pgbin ne "" or $pgbin = _which($cmd);
 671                 if (defined($pgbin) && $pgbin ne "") {
 672                         $pgbin =~ /^(.+)$/ and push(@cmd, $1);
 673                 } else {
 674                         $cmd =~ /\s/ || is_shellish($cmd) or
 675                                 return undef;
 676                         my $sh = $Girocco::Config::posix_sh_bin;
 677                         defined($sh) && $sh ne "" or $sh = '/bin/sh';
 678                         push(@cmd, $sh, "-c", $cmd, $sh);
 679                 }
 680         }
 681         if (!@cmd) {
 682                 my $pgbin = _which("less");
 683                 $pgbin or $pgbin = _which("more");
 684                 defined($pgbin) && $pgbin ne "" or return undef;
 685                 $pgbin =~ /^(.+)$/ and push(@cmd, $1);
 686         }
 687         local $ENV{LESS} = "-FRX" unless exists($ENV{LESS});
 688         local $ENV{LV} = "-c" unless exists($ENV{LV});
 689         my $pghnd;
 690         use POSIX ();
 691         my ($rfd, $wfd) = POSIX::pipe();
 692         defined($rfd) && defined($wfd) && $rfd >= 0 && $wfd >= 0 or
 693                 die "POSIX::pipe failed: $!\n";
 694         my $pid = fork();
 695         defined($pid) or
 696                 die "fork failed: $!\n";
 697         if (!$magic && !$pid || $magic && $pid) {
 698                 POSIX::close($wfd);
 699                 POSIX::dup2($rfd, 0);
 700                 POSIX::close($rfd);
 701                 $magic and $SIG{CHLD} = 'IGNORE';
 702                 exec {$cmd[0]} @cmd or
 703                         die "exec \"$cmd[0]\" failed: $!\n";
 704         }
 705         $magic and $pid = getppid();
 706         POSIX::close($rfd);
 707         open $pghnd, '>&=', $wfd or
 708                         die "fdopen of pipe write end failed: $!\n";
 709         defined($pid) && defined($pghnd) or return undef;
 710         return wantarray ? ($pghnd, $pid) : $pghnd;
 711 }
 712
 713 # return true if any of the known PAGER_IN_USE environment
 714 # variables are set
 715 sub pager_in_use {
 716         return $ENV{GIT_PAGER_IN_USE} || $ENV{TG_PAGER_IN_USE};
 717 }
 718
 719 # possibly set STDOUT to flow through a pager
 720 # $_[0]:
 721 #   defined and false  -> return without doing anything
 722 #   defined and true   -> set STDOUT to setup_pager result
 723 #   undefined:
 724 #     ! -t STDOUT      -> return without doing anything
 725 #     -t STDOUT:
 726 #       $_[1] is false -> set STDOUT to setup_pager result
 727 #       $_[1] is true  -> return without doing anything
 728 # $[1] means do NOT enable paging by default on -t STDOUT
 729 # Most clients can simply call this function without arguments
 730 # which will add a pager only if STDOUT is a terminal
 731 # If pager_in_use, returns without doing anything.
 732 # If pager is activated, sets known pager in use env vars.
 733 sub setup_pager_stdout {
 734         pager_in_use() and return;
 735         my $want_pager = $_[0];
 736         defined($want_pager) or
 737                 $want_pager = (-t STDOUT) ? !$_[1] : 0;
 738         return unless $want_pager;
 739         my $pghnd = setup_pager('become child');
 740         defined($pghnd) or return;
 741         if (open(STDOUT, '>&=', $pghnd)) {
 742                 $ENV{GIT_PAGER_IN_USE} = 1;
 743                 $ENV{TG_PAGER_IN_USE} = 1;
 744         } else {
 745                 die "failed to set STDOUT to pager: $!\n";
 746         }
 747 }
 748
 749 1;