toolbox/projtool.pl

   1 #!/usr/bin/perl
   2
   3 # projtool.pl - command line Girocco project maintenance tool
   4 # Copyright (C) 2016,2017,2020,2021 Kyle J. McKay.  All rights reserved.
   5 # License GPLv2+: GNU GPL version 2 or later.
   6 # www.gnu.org/licenses/gpl-2.0.html
   7 # This is free software: you are free to change and redistribute it.
   8 # There is NO WARRANTY, to the extent permitted by law.
   9
  10 use strict;
  11 use warnings;
  12 use vars qw($VERSION);
  13 BEGIN {*VERSION = \'1.10.0'}
  14 use File::Basename;
  15 use Digest::MD5 qw(md5_hex);
  16 use IO::Socket;
  17 use Cwd qw(realpath);
  18 use POSIX qw(strftime);
  19
  20 my $origHOME;
  21 BEGIN {$origHOME = $ENV{HOME}}
  22
  23 use lib "__BASEDIR__";
  24 use Girocco::Config;
  25 use Girocco::Util;
  26 use Girocco::HashUtil;
  27 use Girocco::CLIUtil;
  28 use Girocco::Project;
  29 use Girocco::User;
  30
  31 exit(&main(@ARGV)||0);
  32
  33 our $help;
  34 BEGIN {my @a; /^(.*)$/s && push(@a, $1) foreach @ARGV; @ARGV=@a;}
  35 BEGIN {$help = <<'HELP'}
  36 Usage: %s [<global option>...] <command> <options>
  37
  38        global options:
  39                   -q | --quiet    suppress warning messages
  40                   -p | --pager    force output to be paginated
  41                   --no-pager      never paginate output
  42
  43        Note that as a convenience, where an existing <project> is required as
  44        an argument, a path to the project may be given instead of the name in
  45        most places.  The "remove" and "prune" commands only accept names.
  46        Since a matching project name takes precedence over a path, to force
  47        interpretation as a path, start the path with "/" or "./" or "../".
  48        Giving "." will find the project matching the current working directory.
  49        Non-destructive commands that take only a <project> name will attempt to
  50        use "." as the project name if it has been omitted.
  51
  52        help [<command>]
  53               show full help or just for <command> if given
  54
  55        list [--verbose] [--sort=lcname|name|owner|gid|no] [--owner] [<regexp>]
  56               list all projects (default is --sort=lcname)
  57               limit to project names matching <regex> if given
  58               match <regex> against owner instead of project name with --owner
  59
  60        create [--force] [--no-alternates] [--orphan] [<option>...] <project>
  61               create new project <project> (prompted)
  62               <option> can be:
  63                   --no-alternates skip setup of objects/info/alternates
  64                   --orphan        allow creation of subproject w/o a parent
  65                   -p              use mkdir -p during --orphan creation
  66                   --no-password   set password crypt to invalid value "unknown"
  67                   --no-owner      leave the gitweb.owner config unset
  68                   --mirror=<url>  create a mirror from <url>
  69                   --full-mirror   mirror all refs
  70                   --push[=<list>] create a push project
  71                   --desc=<string> specify project description w/o prompt
  72                   --homepage=<url> specify project homepage URL w/o prompt
  73                   --defaults      do no interactive prompting at all
  74               Using --no-password skips the prompts for password, using
  75               --no-owner skips the prompt for owner and using --mirror=<url>
  76               or --push[=<list>] skips the prompts for mirror URL and
  77               heads-only and push users.  With --defaults if neither
  78               --mirror=<url> nor --push[=<list>] is given then --push will
  79               be implied.  Using --desc=<string> will force a specific
  80               description (including an empty string) and skip the prompt for
  81               it.  Otherwise a non-empty default description will always be
  82               supplied in lieu of an empty or omitted description.
  83
  84        adopt [--force] [--type=mirror|push] [<option>...] <project> [<users>]
  85               adopt project <project>
  86               type of project is guessed if --type=<type> omitted
  87               <users> is same as <newuserslist> for setusers command
  88               <option> can be:
  89                   --dry-run     do all the checks but don't perform adoption
  90                   --verbose     show project info dump (useful with --dry-run)
  91                   --no-users    no push users at all (<users> must be omitted)
  92                   --no-owner    leave the gitweb.owner config totally unchanged
  93                   --owner=<val> set the gitweb.owner config to <val>
  94               Both --no-owner and --owner=<val> may NOT be given, with neither
  95               take owner from preexisting gitweb.owner else use admin setting.
  96               For mirrors <users> is ignored otherwise if no <users> and no
  97               --no-users option the push users list will consist of the single
  98               user name matching the owner or empty if none or more than one.
  99               With --dry-run <project> can be an absolute path to a git dir.
 100
 101        remove [--force] [--really-delete] [--keep-forks] <project>
 102               remove project <project>
 103               do not move to _recyclebin with --really-delete (just rm -rf)
 104               remove projects with forks (by keeping forks) using --keep-forks
 105
 106        prune [--quiet] (--force | --dry-run) [<project>...]
 107               check to see if any projects (default is all projects) are
 108               missing the associated project directory on disk.
 109               Requires either --force or --dry-run option to operate.
 110               With --dry-run only show what would be done.
 111               With --prune actually remove any extraneous project(s).
 112               With --dry-run exit code is non-zero if any action needed.
 113               With --quiet, suppress output message, if any.
 114
 115        show <project>
 116               show project <project>
 117
 118        verify [--quiet] [--dir] <project>
 119               show the canonical project name for <project> (which might
 120               be a path) if and only if it exists.  With --dir show the
 121               canonical full path to the project directory instead.
 122               If the project name is invalid or does not exist, display
 123               an error (unless --quiet is used).  Exit status will be 0
 124               if project found, non-zero otherwise.
 125
 126        worktree[s] [--force] <project> [<git worktree arguments>]
 127               run 'git --git-dir=<project-git-dir> worktree <worktree args>'
 128               except that if <git worktree arguments> consists of the
 129               subcommand "add" and a single non-option argument and the
 130               <project>'s git-dir is bare (the usual case) and the <project>'s
 131               HEAD branch is not already checked out in any other worktree,
 132               then suitable arguments will be passed to the `worktree`
 133               command to make the newly created worktree checkout the HEAD
 134               branch of the project (special logic makes that work even
 135               for an unborn HEAD).
 136               With --force allow running on a mirror project
 137               With no <git worktree arguments> use "list"
 138
 139        urls [--push | --bundle] <project>
 140               show available fetch/push URLs for <project>
 141               Note that this does NOT include non-Git protocol URLs such
 142               as any home page or any upstream URL for a mirror project --
 143               those are all accessible via the "show" command.
 144               The URLs shown are those that would be shown by gitweb.cgi.
 145               With --push only show push urls (mirrors have no push urls)
 146               With --bundle show downloadble bundle urls instead
 147
 148        listheads <project>
 149               list all available heads for <project> and indicate current head
 150
 151        listalltags [--projects] [--counts] [--filter=<regex>] [<project>...]
 152               list all ctags on all projects or just the projects specified
 153               using the gitweb project cache file.
 154               with --cache-info (no projects allowed) show cache up-to-dateness
 155               with --projects include indented list of projects under each ctag
 156               with --counts include count after ctag and before project name
 157               with --filter only include ctags matching Perl <regex>
 158               with --ignore-case/-i pattern and ctags ignore case
 159               See also show-tags.pl and clean-tags.pl toolbox utilities.
 160
 161        listtags [--verbose] <project>
 162               list all ctags on project <project>
 163               with --verbose include tag counts
 164
 165        deltags <project> [--ignore-case/-i] <tagstodel>
 166               remove any ctags on project <project> present in <tagstodel>
 167               <tagstodel> is space or comma separated list of tags to remove
 168               with -i match against <tagstodel> without regard to letter case
 169
 170        addtags <project> <tagstoadd>
 171               add ctags to project <project>
 172               <tagstoadd> is space or comma separated list of tags to add
 173
 174        chpass [--force] <project> [random | unknown]
 175               change project <project> password (prompted)
 176               with "random" set to random password
 177               with "unknown" set password hash to invalid value "unknown"
 178
 179        checkpw <project>
 180               check project <project> password for a match (prompted)
 181
 182        gc [--force | --auto] [--redelta | --recompress] <project>
 183               run the gc.sh script on project <project>
 184               with --auto let the gc.sh script decide what to do
 185               with --force cause a full gc to take place (force_gc=1)
 186               with neither --auto nor --force do a mini or if needed a full gc
 187               (in other words just touch .needsgc and run gc.sh)
 188               with --redelta a full gc will use pack-objects --no-reuse-delta
 189               with --recompress a full gc uses pack-objects --no-reuse-object
 190               (--no-reuse-delta and --no-reuse-object are accepted as aliases)
 191               with --aggressive activate the --force and --redelta options
 192               unless the global --quiet option is given show_progress=1 is used
 193
 194        update [--force] [--quiet | --summary] <project>
 195               run the update.sh script on project <project>
 196               with --force cause a fetch to always take place (force_update=1)
 197               with --quiet only show errors (show_progress is left unset)
 198               with --summary show progress and ref summary (show_progress=1)
 199               with neither --quiet nor --summary show it all (show_progress=2)
 200
 201        remirror [--force] <project>
 202               initiate a remirror of project <project>
 203
 204        [set]owner [--force] <project> <newowner>
 205               set project <project> owner to <newowner>
 206               without "set" and only 1 arg, just show current project owner
 207
 208        [set]desc [--force] <project> <newdesc>
 209               set project <project> description to <newdesc>
 210               without "set" and only 1 arg, just show current project desc
 211
 212        [set]readme [--force] [--format=<readmetype>] <project> [<newsetting>]
 213               set project <project> readme to <newsetting>
 214               <readmetype> is markdown|plain|html (default is no change)
 215               <newsetting> is automatic|suppressed|-|[@]filename
 216               with "set" <readmetype> and/or <newsetting> is required
 217               without "set" and only 1 arg, just show current readme setting
 218
 219        [set]head [--force] <project> <newhead>
 220               set project <project> HEAD symbolic ref to <newhead>
 221               without "set" and only 1 arg, just show current project HEAD
 222
 223        [set]bool [--force] <project> <flagname> <boolvalue>
 224               set project <project> boolean <flagname> to <boolvalue>
 225               <flagname> is cleanmirror|reverseorder|summaryonly|statusupdtaes
 226               without "set" and only 2 args, just show current flag value
 227
 228        [set]hooks [--force] <project> local | global | <path>
 229               set project <project> hookspath to local, global or <path>
 230               without "set" and only 1 arg, just show current hookspath
 231
 232        [set]autogchack <project> <boolvalue> | unset
 233               set project <project> autogchack to <boolvalue> or "unset" it
 234               without "set" just show current autogchack setting if enabled
 235               with "set" autogchack must be enabled in Config.pm for the
 236               type of project and maintain-auto-gc-hack.sh is always run
 237
 238        [set]url [--force] <project> <urlname> <newurlvalue>
 239               set project <project> url <urlname> to <newurlvalue>
 240               <urlname> is baseurl|homepage|notifyjson
 241               without "set" and only 2 args, just show current url value
 242
 243        [set]msgs [--force] <project> <msgsname> <eaddrlist>
 244               set project <project> msgs <msgsname> to <addrlist>
 245               <msgsname> is notifymail|notifytag
 246               <eaddrlist> is space or comma separated list of email addresses
 247               without "set" and only 2 args, just show current msgs value
 248
 249        [set]users [--force] <project> <newuserslist>
 250               set push project <project> users list to <newuserslist>
 251               <newuserslist> is space or comma separated list of user names
 252               without "set" and only 1 arg, just show current users list
 253
 254        [set]jsontype <project> <newjsontype>
 255               set project <project> JSON Content-Type to <newjsontype>
 256               <newjsontype> is x-www-form-urlencoded or json
 257               without "set" and only 1 arg, just show current jsontype
 258
 259        [set]jsonsecret <project> <newjsonsecret>
 260               set project <project> JSON secret to <newjsonsecret>
 261               <newjsonsecret> is a string (empty string disables signatures)
 262               without "set" and only 1 arg, just show current jsonsecret
 263
 264        get <project> <fieldname>
 265               show project <project> field <fieldname>
 266               <fieldname> is owner|desc|readme|head|hooks|users|jsontype
 267                       or jsonsecret|<flagname>|autogchack|<urlname>|<msgsname>
 268
 269        set [--force] <project> <fieldname> <newfieldvalue>
 270               set project <project> field <fieldname> to <newfieldvalue>
 271               <fieldname> same as for get
 272               <newfieldvalue> same as for corresponding set... command
 273 HELP
 274
 275 our $quiet;
 276 our $usepager;
 277 our $setopt;
 278 sub die_usage {
 279         my $sub = shift || diename;
 280         if ($sub) {
 281                 die "Invalid arguments to $sub command -- try \"help\"\n";
 282         } else {
 283                 die "Invalid arguments -- try \"help\"\n";
 284         }
 285 }
 286
 287 sub get_readme_len {
 288         my $rm = shift;
 289         defined($rm) or $rm = '';
 290         return "length " . length($rm);
 291 }
 292
 293 sub get_readme_desc {
 294         my $rm = shift;
 295         defined($rm) or $rm = '';
 296         if (length($rm)) {
 297                 my $test = $rm;
 298                 $test =~ s/<!--(?:[^-]|(?:-(?!-)))*-->//gs;
 299                 $test =~ s/\s+//s;
 300                 return $test eq '' ? "suppressed" : "length " . length($rm);
 301         } else {
 302                 return "automatic";
 303         }
 304 }
 305
 306 sub get_ctag_counts {
 307         my $project = shift;
 308         my $compact = shift;
 309         my @ctags = ();
 310         foreach ($project->get_ctag_names) {
 311                 my $val = 0;
 312                 my $ct;
 313                 if (open $ct, '<', $project->{path}."/ctags/$_") {
 314                         my $count = <$ct>;
 315                         close $ct;
 316                         defined $count or $count = '';
 317                         chomp $count;
 318                         $val = $count =~ /^[1-9]\d*$/ ? $count : 1;
 319                 }
 320                 if ($compact) {
 321                         if ($val == 1) {
 322                                 push(@ctags, $_);
 323                         } elsif ($val > 1) {
 324                                 push(@ctags, $_."(".$val.")");
 325                         }
 326                 } else {
 327                         push(@ctags, [$_, $val]) if $val;
 328                 }
 329         }
 330         @ctags;
 331 }
 332
 333 sub reftype {
 334         use Scalar::Util ();
 335         return ref($_[0]) ? Scalar::Util::reftype($_[0]) : ''
 336 };
 337
 338 sub get_project_harder_gently {
 339         defined($_[0]) && return get_project_harder(@_);
 340         my $proj = eval { get_project_harder(".") };
 341         reftype($proj) eq 'HASH' or $proj = undef;
 342         return $proj;
 343 }
 344
 345 sub get_clean_project_gently {
 346         defined($_[0]) && return get_clean_project(@_);
 347         my $proj = eval { get_clean_project(".") };
 348         reftype($proj) eq 'HASH' or $proj = undef;
 349         return $proj;
 350 }
 351
 352 sub get_clean_project {
 353         my $project = get_project_harder(@_);
 354         delete $project->{loaded};
 355         delete $project->{base_path};
 356         delete $project->{ccrypt};
 357         /^orig/i || !defined($project->{$_}) and delete $project->{$_} foreach keys %$project;
 358         $project->{owner} = $project->{email}; delete $project->{email};
 359         $project->{homepage} = $project->{hp}; delete $project->{hp};
 360         $project->{baseurl} = $project->{url}; delete $project->{url};
 361         if (defined($project->{path}) && $project->{path} ne "") {
 362                 my $rp = realpath($project->{path});
 363                 defined($rp) && $rp ne "" and $project->{realpath} = $rp;
 364                 if (-f "$rp/objects/info/packs") {
 365                         my $ipt = (stat _)[9];
 366                         defined($ipt) and $project->{infopackstime} =
 367                                 strftime("%Y-%m-%d %H:%M:%S %z", localtime($ipt));
 368                 }
 369         }
 370         my $owner = $project->{owner};
 371         if ($owner) {
 372                 $owner = lc($owner);
 373                 my @owner_users = map {$owner eq lc($$_[4]) ? $$_[1] : ()} get_all_users;
 374                 $project->{owner_users} = \@owner_users if @owner_users;
 375         }
 376         my $projname = $project->{name};
 377         my @forks = grep {$$_[1] =~ m,^$projname/,} get_all_projects;
 378         $project->{has_forks} = 1 if @forks;
 379         $project->{has_alternates} = 1 if $project->has_alternates;
 380         my @bundles = $project->bundles;
 381         for (my $i = 0; $i < @bundles; ++$i) {
 382                 my $secs = $bundles[$i]->[0];
 383                 $bundles[$i]->[0] = strftime("%Y-%m-%d %H:%M:%S %z", localtime($secs));
 384                 my $sz = $bundles[$i]->[2];
 385                 1 while $sz =~ s/(?<=\d)(\d{3})(?:,|$)/,$1/g;
 386                 $bundles[$i]->[2] = $sz;
 387         }
 388         delete $project->{bundles};
 389         $project->{bundles} = \@bundles if @bundles;
 390         $project->{mirror} = 0 unless $project->{mirror};
 391         $project->{is_empty} = 1 if $project->is_empty;
 392         delete $project->{showpush} unless $project->{showpush};
 393         delete $project->{users} if $project->{mirror};
 394         delete $project->{baseurl} unless $project->{mirror};
 395         delete $project->{banged} unless $project->{mirror};
 396         delete $project->{lastrefresh} unless $project->{mirror};
 397         delete $project->{cleanmirror} unless $project->{mirror};
 398         delete $project->{statusupdates} unless $project->{mirror};
 399         delete $project->{lastparentgc} unless $projname =~ m,/,;
 400         unless ($project->{banged}) {
 401                 delete $project->{bangcount};
 402                 delete $project->{bangfirstfail};
 403                 delete $project->{bangmessagesent};
 404         }
 405         my $projhook = $project->_has_notifyhook;
 406         if (defined($projhook) && $projhook ne "") {
 407                 $project->{notifyhook} = $projhook;
 408         } else {
 409                 delete $project->{notifyhook};
 410         }
 411         $project->{README} = get_readme_desc($project->{README}) if exists($project->{README});
 412         $project->{READMEDATA} = get_readme_len($project->{READMEDATA}) if exists($project->{READMEDATA});
 413         my @tags = get_ctag_counts($project, 1);
 414         $project->{tags} = \@tags if @tags;
 415         my $projconfig = read_config_file_hash($project->{path}."/config");
 416         if (defined($projconfig) && defined($projconfig->{"core.hookspath"})) {
 417                 my $ahp = $projconfig->{"core.hookspath"};
 418                 my $rahp = realpath($ahp);
 419                 my $lhp = $project->{path}."/hooks";
 420                 my $rlhp = realpath($lhp);
 421                 my $ghp = $Girocco::Config::reporoot."/_global/hooks";
 422                 my $rghp = realpath($ghp);
 423                 $project->{has_local_hooks} = 1 if
 424                         defined($rahp) && defined($rlhp) && $rahp eq $rlhp;
 425                 $project->{has_global_hooks} = 1 if
 426                         defined($rahp) && defined($rghp) && $rahp eq $rghp;
 427                 $project->{hookspath} = $ahp unless $ahp eq $lhp || $ahp eq $ghp;
 428         }
 429         $project;
 430 }
 431
 432 sub clean_addrlist {
 433         my %seen = ();
 434         my @newlist = ();
 435         foreach (split(/[,\s]+/, $_[0])) {
 436                 next unless $_;
 437                 $seen{lc($_)} = 1, push(@newlist, $_) unless $seen{lc($_)};
 438         }
 439         return join(($_[1]||","), @newlist);
 440 }
 441
 442 sub valid_addrlist {
 443         my $cleaned = clean_addrlist(join(" ", @_));
 444         return 1 if $cleaned eq "";
 445         valid_email_multi($cleaned) && length($cleaned) <= 512;
 446 }
 447
 448 sub validate_users {
 449         my ($userlist, $force, $nodie) = @_;
 450         my @newusers = ();
 451         my $badlist = 0;
 452         my %seenuser = ();
 453         my $mobok = $Girocco::Config::mob && $Girocco::Config::mob eq "mob";
 454         my %users = map({($$_[1] => $_)} get_all_users);
 455         foreach (split(/[\s,]+/, $userlist)) {
 456                 if (exists($users{$_}) || $_ eq "everyone" || ($mobok && $_ eq "mob")) {
 457                         $seenuser{$_}=1, push(@newusers, $_) unless $seenuser{$_};
 458                         next;
 459                 }
 460                 if (Girocco::User::does_exist($_, 1)) {
 461                         if ($force) {
 462                                 $seenuser{$_}=1, push(@newusers, $_) unless $seenuser{$_};
 463                         } else {
 464                                 $badlist = 1;
 465                                 warn "refusing to allow questionable user \"$_\" without --force\n" unless $nodie && $quiet;
 466                         }
 467                         next;
 468                 }
 469                 $badlist = 1;
 470                 warn "invalid user: \"$_\"\n" unless $nodie && $quiet
 471         }
 472         die if $badlist && !$nodie;
 473         return @newusers;
 474 }
 475
 476 sub is_default_desc {
 477         # "Unnamed repository; edit this file 'description' to name the repository."
 478         # "Unnamed repository; edit this file to name it for gitweb."
 479         local $_ = shift;
 480         return 0 unless defined($_);
 481         /Unnamed\s+repository;/i && /\s+edit\s+this\s+file\s+/i && /\s+to\s+name\s+/i;
 482 }
 483
 484 sub valid_desc {
 485         my $test = shift;
 486         chomp $test;
 487         return 0 if $test =~ /[\r\n]/;
 488         $test =~ s/\s\s+/ /g;
 489         $test =~ s/^\s+//;
 490         $test =~ s/\s+$//;
 491         return $test ne '';
 492 }
 493
 494 sub clean_desc {
 495         my $desc = shift;
 496         defined($desc) or $desc = '';
 497         chomp $desc;
 498         $desc = to_utf8($desc, 1);
 499         $desc =~ s/\s\s+/ /g;
 500         $desc =~ s/^\s+//;
 501         $desc =~ s/\s+$//;
 502         return $desc;
 503 }
 504
 505 sub parse_options {
 506         Girocco::CLIUtil::_parse_options(
 507                 sub {
 508                         warn((($_[0]eq'?')?"unrecognized":"missing argument for")." option \"$_[1]\"\n")
 509                                 unless $quiet;
 510                         die_usage;
 511                 }, @_);
 512 }
 513
 514 sub cmd_list {
 515         my %sortsub = (
 516                 lcname => sub {lc($$a[1]) cmp lc($$b[1])},
 517                 name => sub {$$a[1] cmp $$b[1]},
 518                 gid => sub {$$a[3] <=> $$b[3]},
 519                 owner => sub {lc($$a[4]) cmp lc($$b[4]) || lc($$a[1]) cmp lc($$b[1])},
 520                 no => sub {$$a[0] <=> $$b[0]},
 521         );
 522         my $sortopt = 'lcname';
 523         my ($verbose, $owner);
 524         parse_options(":sort" => \$sortopt, verbose => \$verbose, owner => \$owner);
 525         my $regex;
 526         if (@ARGV) {
 527                 my $val = shift @ARGV;
 528                 $regex = qr($val) or die "bad regex \"$val\"\n";
 529         }
 530         !@ARGV && exists($sortsub{$sortopt}) or die_usage;
 531         my $sortsub = $sortsub{$sortopt};
 532         my $grepsub = defined($regex) ? ($owner ? sub {$$_[4] =~ /$regex/} : sub {$$_[1] =~ /$regex/}) : sub {1};
 533         my @projects = sort($sortsub grep {&$grepsub} get_all_projects);
 534         if ($verbose) {
 535                 print map(sprintf("%s\n", join(":", (@$_)[1..5])), @projects);
 536         } else {
 537                 print map(sprintf("%s: %s\n", $$_[1], $$_[5] =~ /^:/ ? "<mirror>" : $$_[5]), @projects);
 538         }
 539         return 0;
 540 }
 541
 542 sub cmd_create {
 543         my ($force, $noalternates, $orphanok, $optp, $nopasswd, $noowner, $defaults, $ispush, $pushusers,
 544                 $ismirror, $desc, $fullmirror, $homepage);
 545         parse_options(
 546                 force => \$force, "no-alternates" => \$noalternates, orphan => \$orphanok, p => \$optp,
 547                 "no-password" => \$nopasswd, "no-owner" => \$noowner, defaults => \$defaults,
 548                 "push" => \$ispush, ":push" => \$pushusers, ":mirror" => \$ismirror, ":desc" => \$desc,
 549                 ":description" => \$desc, "full-mirror" => \$fullmirror, ":homepage" => \$homepage);
 550         @ARGV == 1 or die_usage;
 551         !defined($pushusers) || defined($ispush) or $ispush = 1;
 552         defined($ismirror) && $ismirror =~ /^\s*$/ and die "--mirror url must not be empty\n";
 553         die "--mirror and --push are mutually exclusive options\n" if $ismirror && $ispush;
 554         die "--full-mirror requires use of --mirror=<url> option\n" if $fullmirror && !$ismirror;
 555         !$defaults || defined($ispush) || defined($ismirror) or $ispush = 1;
 556         !$defaults || defined($nopasswd) or $nopasswd = 1;
 557         !$defaults || defined($noowner) or $noowner = 1;
 558         !defined($ispush) || defined($pushusers) or $pushusers = "";
 559         my $projname = $ARGV[0];
 560         $projname =~ s/\.git$//i;
 561         Girocco::Project::does_exist($projname, 1) and die "Project already exists: \"$projname\"\n";
 562         if (!Girocco::Project::valid_name($projname, $orphanok, $optp)) {
 563                 warn "Refusing to create orphan project without --orphan\n"
 564                         if !$quiet && !$orphanok && Girocco::Project::valid_name($projname, 1, 1);
 565                 warn "Required orphan parent directory does not exist (use -p): ",
 566                         $Girocco::Config::reporoot.'/'.Girocco::Project::get_forkee_name($projname), "\n"
 567                         if !$quiet && $orphanok && Girocco::Project::valid_name($projname, 1, 1);
 568                 die "Invalid project name: \"$projname\"\n";
 569         }
 570         my ($forkee, $project) = ($projname =~ m#^(.*/)?([^/]+)$#);
 571         my $newtype = $forkee ? 'fork' : 'project';
 572         if (length($project) > 64) {
 573                 die "The $newtype name is longer than 64 characters.  Do you really need that much?\n"
 574                         unless $force;
 575                 warn "Allowing $newtype name longer than 64 characters with --force\n" unless $quiet;
 576         }
 577         unless ($Girocco::Config::push || $Girocco::Config::mirror) {
 578                 die "Project creation disabled (no mirrors or push projects allowed)\n" unless $force;
 579                 warn "Continuing with --force even though both push and mirror projects are disabled\n" unless $quiet;
 580         }
 581         print "Enter settings for new project \"$projname\"\n" unless $defaults;
 582         my %settings = ();
 583         $settings{noalternates} = $noalternates;
 584         if ($nopasswd) {
 585                 $settings{crypt} = "unknown";
 586         } else {
 587                 my $np1 = prompt_noecho_nl_or_die("Admin password for project $projname (echo is off)");
 588                 $np1 ne "" or die "empty passwords are not permitted (brokenness will ensue)\n";
 589                 my $np2 = prompt_noecho_nl_or_die("Retype admin password for project $projname");
 590                 $np1 eq $np2 or die "Our high-paid security consultants have determined that\n" .
 591                         "the admin passwords you have entered do not match each other.\n";
 592                 $settings{crypt} = scrypt_sha1($np1);
 593         }
 594         my $owner = "";
 595         unless ($noowner) {{
 596                 $owner = prompt_or_die("Owner/email name for project $projname");
 597                 unless (valid_email($owner)) {
 598                         unless ($force) {
 599                                 warn "Your email sure looks weird...?\n";
 600                                 redo;
 601                         }
 602                         warn "Allowing invalid email with --force\n" unless $quiet;
 603                 }
 604                 if (length($owner) > 96) {
 605                         unless ($force) {
 606                                 warn "Your email is longer than 96 characters.  Do you really need that much?\n";
 607                                 redo;
 608                         }
 609                         warn "Allowing email longer than 96 characters with --force\n" unless $quiet;
 610                 }
 611         }}
 612         $settings{email} = $owner;
 613         my $baseurl = "";
 614         my $checkmirror = sub {
 615                 my $checkurl = shift;
 616                 unless (valid_repo_url($checkurl)) {
 617                         unless ($force) {
 618                                 warn "Invalid mirror URL: \"$checkurl\"\n";
 619                                 return undef;
 620                         }
 621                         warn "Allowing invalid mirror URL with --force\n" unless $quiet;
 622                 }
 623                 if ($Girocco::Config::restrict_mirror_hosts) {
 624                         my $mh = extract_url_hostname($checkurl);
 625                         unless (is_dns_hostname($mh)) {
 626                                 unless ($force) {
 627                                         warn "Invalid non-DNS mirror URL: \"$checkurl\"\n";
 628                                         return undef;
 629                                 }
 630                                 warn "Allowing non-DNS mirror URL with --force\n" unless $quiet;
 631                         }
 632                         if (is_our_hostname($mh)) {
 633                                 unless ($force) {
 634                                         warn "Invalid same-host mirror URL: \"$checkurl\"\n";
 635                                         return undef;
 636                                 }
 637                                 warn "Allowing same-host mirror URL with --force\n" unless $quiet;
 638                         }
 639                 }
 640                 return $checkurl;
 641         };
 642         if ($ispush || $ismirror) {
 643                 !$ispush || $force || $Girocco::Config::push or
 644                         die "Push projects are disabled, create a mirror (or use --force)\n";
 645                 !$ismirror || $force || $Girocco::Config::mirror or
 646                         die "Mirror projects are disabled, create a push project (or use --force)\n";
 647                 if ($ismirror) {
 648                         &$checkmirror($ismirror) or die "Invalid --mirror URL\n";
 649                         $baseurl = $ismirror;
 650                         $settings{url} = $baseurl;
 651                         $settings{cleanmirror} = $fullmirror ? 0 : 1;
 652                 } else {
 653                         my @newusers = ();
 654                         if ($pushusers !~ /^[\s,]*$/) {
 655                                 eval {@newusers = validate_users($pushusers, $force); 1;} or
 656                                         die "Invalid --push user list\n";
 657                         }
 658                         $settings{users} = \@newusers;
 659                 }
 660         } elsif ($force || $Girocco::Config::mirror) {{
 661                 if ($force || $Girocco::Config::push) {
 662                         $baseurl = prompt_or_die("URL to mirror from (leave blank for push project)", "");
 663                 } else {{
 664                         $baseurl = prompt_or_die("URL to mirror from");
 665                         unless ($baseurl ne "") {
 666                                 warn "Push projects are disabled, you must enter a mirror URL (or use --force)\n";
 667                                 redo;
 668                         }
 669                 }}
 670                 if ($baseurl ne "") {
 671                         &$checkmirror($baseurl) or redo;
 672                         $settings{url} = $baseurl;
 673                         $settings{cleanmirror} =
 674                                 ynprompt_or_die("Mirror only heads, tags and notes (Y/n)", "Yes");
 675                 }
 676         }}
 677         my $mirror = ($baseurl eq "") ? 0 : 1;
 678         my $checkdesc = sub {
 679                 my $d = shift;
 680                 if (length($d) > 1024) {
 681                         unless ($force) {
 682                                 warn "Short description length greater than 1024 characters!\n";
 683                                 return undef;
 684                         }
 685                         warn "Allowing short description length greater than 1024 characters\n" unless $quiet;
 686                 }
 687                 return $d;
 688         };
 689         if (defined($desc)) {
 690                 $desc =~ s/^\s+//; $desc =~ s/\s+$//;
 691                 $desc eq "" || &$checkdesc($desc) or
 692                         die "Invalid --desc description\n";
 693         } elsif (!$defaults) {{
 694                 $desc = prompt_or_die("Short description", "");
 695                 $desc =~ s/^\s+//; $desc =~ s/\s+$//;
 696                 $desc eq "" || &$checkdesc($desc) or redo;
 697                 $desc = undef if $desc eq "";
 698         }}
 699         defined($desc) or $desc = $mirror ? "Mirror of $baseurl" : "Push project $projname";
 700         $settings{desc} = $desc;
 701         my $checkhp = sub {
 702                 my $hpurl = shift;
 703                 unless (valid_web_url($hpurl)) {
 704                         unless ($force) {
 705                                 warn "Invalid home page URL: \"$hpurl\"\n";
 706                                 return undef;
 707                         }
 708                         warn "Allowing invalid home page URL with --force\n" unless $quiet;
 709                 }
 710                 return $hpurl;
 711         };
 712         if (defined($homepage)) {
 713                 $homepage =~ s/^\s+//; $homepage =~ s/\s+$//;
 714                 $homepage eq "" || &$checkhp($homepage) or
 715                         die "Invalid --homepage URL\n";
 716         } elsif (!$defaults) {{
 717                 $homepage = prompt_or_die("Home page URL", "");
 718                 $homepage =~ s/^\s+//; $homepage =~ s/\s+$//;
 719                 $homepage eq "" || &$checkhp($homepage) or redo;
 720                 $homepage = undef if $homepage eq "";
 721         }}
 722         $settings{hp} = $homepage;
 723         my $jsonurl = "";
 724         if (!$defaults) {{
 725                 $jsonurl = prompt_or_die("JSON notify POST URL", "");
 726                 if ($jsonurl ne "" && !valid_web_url($jsonurl)) {
 727                         unless ($force) {
 728                                 warn "Invalid JSON notify POST URL: \$jsonurl\"\n";
 729                                 redo;
 730                         }
 731                         warn "Allowing invalid JSON notify POST URL with --force\n" unless $quiet;
 732                 }
 733         }}
 734         $settings{notifyjson} = $jsonurl;
 735         my $commitaddrs = "";
 736         if (!$defaults) {{
 737                 $commitaddrs = clean_addrlist(prompt_or_die("Commit notify email addr(s)", ""));
 738                 if ($commitaddrs ne "" && !valid_addrlist($commitaddrs)) {
 739                         unless ($force) {
 740                                 warn"invalid commit notify email address list (use --force to accept): \"$commitaddrs\"\n";
 741                                 redo;
 742                         }
 743                         warn "using invalid commit notify email address list with --force\n" unless $quiet;
 744                 }
 745         }}
 746         $settings{notifymail} = $commitaddrs;
 747         $settings{reverseorder} = 1;
 748         $settings{reverseorder} = ynprompt_or_die("Oldest-to-newest commit order in emails", "Yes")
 749                 if !$defaults && $commitaddrs ne "";
 750         $settings{summaryonly} = ynprompt_or_die("Summary only (no diff) in emails", "No")
 751                 if !$defaults && $commitaddrs ne "";
 752         my $tagaddrs = "";
 753         if (!$defaults) {{
 754                 $tagaddrs = clean_addrlist(prompt_or_die("Tag notify email addr(s)", ""));
 755                 if ($tagaddrs ne "" && !valid_addrlist($tagaddrs)) {
 756                         unless ($force) {
 757                                 warn"invalid tag notify email address list (use --force to accept): \"$tagaddrs\"\n";
 758                                 redo;
 759                         }
 760                         warn "using invalid tag notify email address list with --force\n" unless $quiet;
 761                 }
 762         }}
 763         $settings{notifytag} = $tagaddrs;
 764         if (!$mirror && !$ispush) {{
 765                 my @newusers = ();
 766                 {
 767                         my $userlist = prompt_or_die("Push users", join(",", @newusers));
 768                         eval {@newusers = validate_users($userlist, $force); 1;} or redo;
 769                 }
 770                 $settings{users} = \@newusers;
 771         }}
 772         my $newproj = Girocco::Project->ghost($projname, $mirror, $orphanok, $optp)
 773                 or die "Girocco::Project->ghost call failed\n";
 774         my ($k, $v);
 775         $newproj->{$k} = $v while ($k, $v) = each(%settings);
 776         my $killowner = sub {
 777                 system($Girocco::Config::git_bin, '--git-dir='.$newproj->{path},
 778                         'config', '--unset', "gitweb.owner");
 779         };
 780         if ($mirror) {
 781                 $newproj->premirror or die "Girocco::Project->premirror failed\n";
 782                 !$noowner or &$killowner;
 783                 $newproj->clone or die "Girocco::Project->clone failed\n";
 784                 warn "Project $projname created and cloning successfully initiated.\n"
 785                         unless $quiet;
 786         } else {
 787                 $newproj->conjure or die "Girocco::Project->conjure failed\n";
 788                 !$noowner or &$killowner;
 789                 warn "New push project fork is empty due to use of --no-alternates\n"
 790                         if !$quiet && $projname =~ m,/, && $noalternates;
 791                 warn "Project $projname successfully created.\n" unless $quiet;
 792         }
 793         return 0;
 794 }
 795
 796 sub git_config {
 797         my $gd = shift;
 798         system($Girocco::Config::git_bin, "--git-dir=$gd", 'config', @_) == 0
 799                 or die "\"git --git-dir='$gd' config ".join(" ", @_)."\" failed.\n";
 800 }
 801
 802 sub cmd_adopt {
 803         my ($force, $type, $nousers, $dryrun, $noowner, $owner, $users, $verbose);
 804         parse_options(force => \$force, ":type" => \$type, "no-users" => \$nousers, "dry-run" => \$dryrun,
 805                 "no-owner" => \$noowner,":owner" => \$owner, quiet => \$quiet, q =>\$quiet, verbose => \$verbose);
 806         @ARGV or die "Please give project name on command line.\n";
 807         my $projname = shift @ARGV;
 808         (!$noowner || !defined($owner)) && (!$nousers || !@ARGV) or die_usage;
 809         !defined($type) || $type eq "mirror" || $type eq "push" or die_usage;
 810         defined($type) or $type = "";
 811         my $projdir;
 812         if ($dryrun && $projname =~ m,^/[^.\s/\\:], && is_git_dir(realpath($projname))) {
 813                 $projdir = realpath($projname);
 814                 $projname = $projdir;
 815                 $projname =~ s/\.git$//i;
 816                 $projname =~ s,/+$,,;
 817                 $projname =~ s,^.*/,,;
 818                 $projname ne "" or $projname = $projdir;
 819         } else {
 820                 $projname =~ s/\.git$//i;
 821                 $projname ne "" or die "Invalid project name \"\".\n";
 822                 unless (Girocco::Project::does_exist($projname, 1)) {
 823                         Girocco::Project::valid_name($projname, 1, 1)
 824                                 or die "Invalid project name \"$projname\".\n";
 825                         die "No such project to adopt: $projname\n";
 826                 }
 827                 defined(Girocco::Project->load($projname))
 828                         and die "Project already known (no need to adopt): $projname\n";
 829                 $projdir = $Girocco::Config::reporoot . "/" . $projname . ".git";
 830                 is_git_dir($projdir) or die "Not a git directory: \"$projdir\"\n";
 831         }
 832         my $config = read_config_file($projdir . "/config");
 833         my %config = ();
 834         %config = map {($$_[0], defined($$_[1])?$$_[1]:"true")} @$config if defined($config);
 835         git_bool($config{"core.bare"}) or die "Not a bare git repository: \"$projdir\"\n";
 836         defined(read_HEAD_symref($projdir)) or die "Project with non-symbolic HEAD ref: \"$projdir\"\n";
 837         @ARGV and $users = [validate_users(join(" ", @ARGV), $force, 1)];
 838         my $desc = "";
 839         if (-e "$projdir/description") {
 840                 open my $fd, '<', "$projdir/description" or die "Cannot open \"$projdir/description\": $!\n";
 841                 {
 842                         local $/;
 843                         $desc = <$fd>;
 844                 }
 845                 close $fd;
 846                 defined $desc or $desc = "";
 847                 chomp $desc;
 848                 $desc = to_utf8($desc, 1);
 849                 is_default_desc($desc) and $desc = "";
 850                 if ($desc ne "" && !valid_desc($desc)) {
 851                         die "invalid 'description' file contents (use --force to accept): \"$desc\"\n"
 852                                 unless $force;
 853                         warn "using invalid 'description' file contents  with --force\n" unless $quiet;
 854                 }
 855                 $desc = clean_desc($desc);
 856                 if (length($desc) > 1024) {
 857                         die "description longer than 1024 chars (use --force to accept): \"$desc\"\n"
 858                                 unless $force;
 859                         warn "using longer than 1024 char description with --force\n" unless $quiet;
 860                 }
 861         }
 862         my $readme = "";
 863         my $origreadme = "";
 864         my $readmedata = "";
 865         my $origreadmedata = "";
 866         my $readmetype = Girocco::Project::_normalize_rmtype($config{"girocco.readmetype"},1);
 867         if (-e "$projdir/README.html") {
 868                 open my $fd, '<', "$projdir/README.html" or die "Cannot open \"$projdir/README.html\": $!\n";
 869                 {
 870                         local $/;
 871                         $readme = <$fd>;
 872                 }
 873                 close $fd;
 874                 defined $readme or $readme = "";
 875                 $readme = to_utf8($readme, 1);
 876                 $readme =~ s/\r\n?/\n/gs;
 877                 $readme =~ s/^\s+//s;
 878                 $readme =~ s/\s+$//s;
 879                 $readme eq "" or $readme .= "\n";
 880                 $origreadme = $readme;
 881                 if (-e "$projdir/README.dat") {
 882                         open my $fd2, '<', "$projdir/README.dat" or die "Cannot open \"$projdir/README.dat\": $!\n";
 883                         {
 884                                 local $/;
 885                                 $readmedata = <$fd2>;
 886                         }
 887                         close $fd2;
 888                         defined $readmedata or $readmedata = "";
 889                         $readmedata = to_utf8($readmedata, 1);
 890                         $readmedata =~ s/\r\n?/\n/gs;
 891                         $readmedata =~ s/^\s+//s;
 892                         $readmedata =~ s/\s+$//s;
 893                         $readmedata eq "" or $readmedata .= "\n";
 894                         $origreadmedata = $readmedata;
 895                 }
 896                 !$readmetype && length($readme) && !length($readmedata) and do {
 897                         # the old HTML format
 898                         $readmetype = 'HTML';
 899                         $readmedata = $readme;
 900                 };
 901                 if (length($readmedata) > 8192) {
 902                         die "readme greater than 8192 chars is too long (use --force to override)\n"
 903                                 unless $force;
 904                         warn "using readme greater than 8192 chars with --force\n" unless $quiet;
 905                 }
 906                 {
 907                         my $dummy = {READMEDATA => $readmedata, rmtype => $readmetype, name => $projname};
 908                         my ($cnt, $err) = Girocco::Project::_lint_readme($dummy, 0);
 909                         if ($cnt) {
 910                                 my $msg = "README: $cnt error";
 911                                 $msg .= "s" unless $cnt == 1;
 912                                 print STDERR "$msg\n", "-" x length($msg), "\n", $err
 913                                         unless $force && $quiet;
 914                                 exit(255) unless $force && $readmetype eq 'HTML';
 915                                 warn "$projname: using invalid raw HTML with --force\n" unless $quiet;
 916                         } else {
 917                                 $readme = $dummy->{README};
 918                         }
 919                 }
 920         }
 921         $readmetype or $readmetype = Girocco::Project::_normalize_rmtype(""); # use default type
 922         # Inspect any remotes now
 923         # Yes, Virginia, remote urls can be multi-valued
 924         my %remotes = ();
 925         foreach (@$config) {
 926                 my ($k,$v) = @$_;
 927                 next unless $k =~ /^remote\.([^\/].*?)\.([^.]+)$/; # remote name cannot start with "/"
 928                 my ($name, $subkey) = ($1, $2);
 929                 $remotes{$name}->{skip} = git_bool($v,1), next if $subkey eq "skipdefaultupdate" || $subkey eq "skipfetchall";
 930                 $remotes{$name}->{mirror} = git_bool($v,1), next if $subkey eq "mirror"; # we might want this
 931                 $remotes{$name}->{vcs} = $v, next if defined($v) && $v !~ /^\s*$/ && $subkey eq "vcs";
 932                 push(@{$remotes{$name}->{$subkey}}, $v), next if defined($v) && $v !~ /^\s*$/ &&
 933                         ($subkey eq "url" || $subkey eq "fetch" || $subkey eq "push" || $subkey eq "pushurl");
 934         }
 935         # remotes.default is the default remote group to fetch for "git remote update" otherwise --all
 936         # the remote names in a group are separated by runs of [ \t\n] characters
 937         # remote names "", ".", ".." and any name starting with "/" are invalid
 938         # a remote with no url or vcs setting is not considered valid
 939         my @check = ();
 940         my $usingall = 0;
 941         if (exists($config{"remotes.default"})) {
 942                 foreach (split(/[ \t\n]+/, $config{"remotes.default"})) {
 943                         next unless exists($remotes{$_});
 944                         my $rmt = $remotes{$_};
 945                         next if !exists($rmt->{url}) && !$rmt->{vcs};
 946                         push(@check, $_);
 947                 }
 948         } else {
 949                 $usingall = 1;
 950                 my %seenrmt = ();
 951                 foreach (@$config) {
 952                         my ($k,$v) = @$_;
 953                         next unless $k =~ /^remote\.([^\/].*?)\.[^.]+$/;
 954                         next if $seenrmt{$1};
 955                         $seenrmt{$1} = 1;
 956                         next unless exists($remotes{$1});
 957                         my $rmt = $remotes{$1};
 958                         next if $rmt->{skip} || (!exists($rmt->{url}) && !$rmt->{vcs});
 959                         push(@check, $1);
 960                 }
 961         }
 962         my @needskip = (); # remotes that need skipDefaultUpdate set to true
 963         my $foundvcs = 0;
 964         my $foundfetch = 0;
 965         my $foundfetchwithmirror = 0;
 966         foreach (@check) {
 967                 my $rmt = $remotes{$_};
 968                 push(@needskip, $_) if $usingall && !exists($rmt->{fetch});
 969                 next unless exists($rmt->{fetch});
 970                 ++$foundfetch;
 971                 ++$foundfetchwithmirror if $rmt->{mirror};
 972                 ++$foundvcs if $rmt->{vcs} || (exists($rmt->{url}) && $rmt->{url}->[0] =~ /^[a-zA-Z0-9][a-zA-Z0-9+.-]*::/);
 973         }
 974         # if we have $foundvcs then we need to explicitly set fetch.prune to false
 975         # if we have $foundfetch > 1 then we need to explicitly set fetch.prune to false
 976         my $neednoprune = !exists($config{"fetch.prune"}) && ($foundvcs || $foundfetch > 1);
 977         my $baseurl = "";
 978         my $needfakeorigin = 0; # if true we need to set remote.origin.skipDefaultUpdate = true
 979         # if remote "origin" exists we always pick up its first url or use ""
 980         if (exists($remotes{origin})) {
 981                 my $rmt = $remotes{origin};
 982                 $baseurl = exists($rmt->{url}) ? $rmt->{url}->[0] : "";
 983                 $needfakeorigin = !exists($rmt->{url}) && !$rmt->{vcs} && !$rmt->{skip};
 984         } else {
 985                 $needfakeorigin = 1;
 986                 # get the first url of the @check remotes
 987                 foreach (@check) {
 988                         my $rmt = $remotes{$_};
 989                         next unless exists($rmt->{url});
 990                         next unless defined($rmt->{url}->[0]) && $rmt->{url}->[0] ne "";
 991                         $baseurl = $rmt->{url}->[0];
 992                         last;
 993                 }
 994         }
 995         my $makemirror = $type eq "mirror" || ($type eq "" && $foundfetch);
 996
 997         # If we have $foundfetch we want to make a mirror but complain if
 998         # we $foundfetchwithmirror as well unless we have --type=mirror.
 999         # Warn if we have --type=push and $foundfetch and !$foundfetchwithmirror.
1000         # Warn if we need to set fetch.prune=false when making a mirror
1001         # Warn if we need to create remote.origin.skipDefaultUpdate when making a mirror
1002         # Complain if @needskip AND !$usingall (warn with --force but don't set skip)
1003         # Warn if $usingall and any @needskip (and set them) if making a mirror
1004         # Warn if making a mirror and $baseurl eq ""
1005         # Warn if we have --type=mirror and !$foundfetch
1006
1007         if ($makemirror) {
1008                 warn "No base URL to mirror from for adopted \"$projname\"\n" unless $quiet || $baseurl ne "";
1009                 warn "Adopting mirror \"$projname\" without any fetch remotes\n" unless $quiet || $foundfetch;
1010                 if ($foundfetchwithmirror) {
1011                         warn "Refusing to adopt mirror \"$projname\" with active remote.<name>.mirror=true remote(s)\n".
1012                             "(Use --type=mirror to override)\n"
1013                                 unless $type eq "mirror";
1014                         exit(255) unless $type eq "mirror" || $dryrun;
1015                         warn "Adopting mirror \"$projname\" with active remote.<name>.mirror=true remotes\n"
1016                                 unless $quiet || $type ne "mirror";
1017                 }
1018                 warn "Setting explicit fetch.prune=false for adoption of mirror \"$projname\"\n"
1019                         if !$quiet && $neednoprune;
1020                 warn "Setting remote.origin.skipDefaultUpdate=true for adoption of mirror \"$projname\"\n"
1021                         if !$quiet && $needfakeorigin;
1022                 if (!$usingall && @needskip) {
1023                         warn "Refusing to adopt mirror empty fetch remote(s) (override with --force)\n"
1024                                 unless $force;
1025                         exit(255) unless $force || $dryrun;
1026                         warn "Adopting mirror with empty fetch remote(s) with --force\n"
1027                                 unless $quiet || !$force;
1028                 }
1029                 warn "Will set skipDefaultUpdate=true on non-fetch remote(s)\n" if !$quiet && $usingall && @needskip;
1030                 warn "Adopting mirror with base URL \"$baseurl\"\n" unless $quiet || $baseurl eq "";
1031         } else {
1032                 warn "Adopting push \"$projname\" but active non-mirror remotes are present\n"
1033                         if !$quiet && $foundfetch && !$foundfetchwithmirror;
1034         }
1035
1036         if (!$noowner && !defined($owner)) {
1037                 # Select the owner
1038                 $owner = $config{"gitweb.owner"};
1039                 if (!defined($owner) || $owner eq "") {
1040                         $owner = $Girocco::Config::admin;
1041                         warn "Using owner \"$owner\" for adopted project\n" unless $quiet;
1042                 }
1043         }
1044         if (!$nousers && !$makemirror && !defined($users)) {
1045                 # select user list for push project
1046                 my $findowner = $owner;
1047                 defined($findowner) or $findowner = $config{"gitweb.owner"};
1048                 $findowner = lc($findowner) if defined($findowner);
1049                 my @owner_users = ();
1050                 @owner_users = map {$findowner eq lc($$_[4]) ? $$_[1] : ()} get_all_users
1051                         if defined($findowner) && $findowner ne "";
1052                 defined($findowner) or $findowner = "";
1053                 if (@owner_users <= 1) {
1054                         $users = \@owner_users;
1055                         warn "No users found that match owner \"$findowner\"\n" unless @owner_users || $quiet;
1056                 } else {
1057                         $users = [];
1058                         warn "Found ".scalar(@owner_users)." users for owner \"$findowner\" (" .
1059                                 join(" ", @owner_users) . ") not setting any\n" unless $quiet;
1060                 }
1061         }
1062         defined($users) or $users = [];
1063
1064         # Warn if we preserve an existing receive.denyNonFastForwards or receive.denyDeleteCurrent setting
1065         # Complain if core.logallrefupdates or logs subdir exists and contains any files (allow with --force
1066         # and warn about preserving the setting)
1067
1068         warn "Preserving existing receive.denyNonFastForwards=true\n"
1069                 if !$quiet && git_bool($config{"receive.denynonfastforwards"});
1070         warn "Preserving existing receive.denyDeleteCurrent=$config{'receive.denydeletecurrent'}\n"
1071                 if !$quiet && exists($config{"receive.denydeletecurrent"}) &&
1072                     $config{"receive.denydeletecurrent"} ne "warn";
1073
1074         my $reflogfiles = Girocco::Project::_contains_files("$projdir/logs");
1075         my $reflogactive = git_bool($config{"core.logallrefupdates"});
1076         if ($reflogactive || $reflogfiles) {
1077                 warn "Refusing to adopt \"$projname\" with active ref logs without --force\n" if $reflogfiles && !$force;
1078                 warn "Refusing to adopt \"$projname\" with core.logAllRefUpdates=true without --force\n" if $reflogactive && !$force;
1079                 exit(255) unless $force || $dryrun;
1080                 warn "Adopting \"$projname\" with active ref logs with --force\n" unless $quiet || ($reflogfiles && !$force);
1081                 warn "Adopting \"$projname\" with core.logAllRefUpdates=true with --force\n" unless $quiet || ($reflogactive && !$force);
1082         }
1083
1084         return 0 if $dryrun && !$verbose;
1085
1086         my $newproj = eval {Girocco::Project->ghost($projname, $makemirror, 1, $dryrun)};
1087         defined($newproj) or die "Girocco::Project::ghost failed: $@\n";
1088         $newproj->{desc} = $desc;
1089         $newproj->{README} = $readme;
1090         $newproj->{READMEDATA} = $readmedata;
1091         $newproj->{rmtype} = $readmetype;
1092         $newproj->{url} = $baseurl if $makemirror || exists($config{"gitweb.baseurl"});
1093         $newproj->{email} = $owner if defined($owner);
1094         $newproj->{users} = $users;
1095         $newproj->{crypt} = "unknown";
1096         $newproj->{reverseorder} = 1 unless exists($config{"hooks.reverseorder"});
1097         $newproj->{summaryonly} = 1 unless exists($config{"hooks.summaryonly"});
1098         my $dummy = bless {}, "Girocco::Project";
1099         $dummy->{path} = "$projdir";
1100         $dummy->{configfilehash} = \%config;
1101         $dummy->_properties_load;
1102         delete $dummy->{origurl};
1103         foreach my $k (keys(%$dummy)) {
1104                 $newproj->{$k} = $dummy->{$k}
1105                         if exists($dummy->{$k}) && !exists($newproj->{$k});
1106         }
1107
1108         if ($verbose) {
1109                 use Data::Dumper;
1110                 my %info = %$newproj;
1111                 $info{README} = get_readme_desc($info{README}) if exists($info{README});
1112                 my $d = Data::Dumper->new([\%info], ['*'.$newproj->{name}]);
1113                 $d->Sortkeys(sub {[sort({lc($a) cmp lc($b)} keys %{$_[0]})]});
1114                 print $d->Dump([\%info], ['*'.$newproj->{name}]);
1115         }
1116         return 0 if $dryrun;
1117
1118         # Make any changes as needed for @needskip, $neednoprune and $needfakeorigin
1119         if ($makemirror) {
1120                 git_config($projdir, "fetch.prune", "false") if $neednoprune;
1121                 git_config($projdir, "remote.origin.skipDefaultUpdate", "true") if $needfakeorigin;
1122                 if ($usingall && @needskip) {
1123                         git_config($projdir, "remote.$_.skipDefaultUpdate", "true") foreach @needskip;
1124                 }
1125         }
1126
1127         # Write out any README.dat/README.html changes before the actual Adoption
1128         # Otherwise they will get stepped on.  The Girocco::Project::adopt function
1129         # does not know how to validate README.html during adoption like the above code does.
1130         if ($readmedata ne $origreadmedata) {
1131                 open my $fd, '>', "$projdir/README.dat" or die "Cannot write \"$projdir/README.dat\": $!\n";
1132                 print $fd $readmedata or die "Error writing \"$projdir/README.dat\": $!\n";
1133                 close $fd or die "Error closing \"$projdir/README.dat\": $!\n";
1134         }
1135         if ($readme ne $origreadme || ! -e "$projdir/README.html") {
1136                 open my $fd, '>', "$projdir/README.html" or die "Cannot write \"$projdir/README.html\": $!\n";
1137                 print $fd $readme or die "Error writing \"$projdir/README.html\": $!\n";
1138                 close $fd or die "Error closing \"$projdir/README.html\": $!\n";
1139         }
1140         git_config($projdir, "girocco.rmtype", $readmetype);
1141
1142         # Perform the actual adoption
1143         $newproj->adopt or die "Girocco::Project::adopt failed\n";
1144
1145         # Perhaps restore core.logAllRefUpdates, receive.denyNonFastForwards and receive.denyDeleteCurrent
1146         git_config($projdir, "receive.denyNonFastForwards", "true")
1147                 if git_bool($config{"receive.denynonfastforwards"});
1148         git_config($projdir, "receive.denyDeleteCurrent", $config{"receive.denydeletecurrent"})
1149                 if exists($config{"receive.denydeletecurrent"}) &&
1150                    $config{"receive.denydeletecurrent"} ne "warn";
1151         git_config($projdir, "core.logAllRefUpdates", "true")
1152                 if $reflogactive;
1153
1154         # Success
1155         if ($makemirror) {
1156                 warn "Mirror project \"$projname\" successfully adopted.\n" unless $quiet;
1157         } else {
1158                 warn "Push project \"$projname\" successfully adopted.\n" unless $quiet;
1159         }
1160         return 0;
1161 }
1162
1163 sub cmd_remove {
1164         my ($force, $reallydel, $keepforks);
1165         parse_options(force => \$force, "really-delete" => \$reallydel,
1166                 "keep-forks" => \$keepforks, quiet => \$quiet, q =>\$quiet);
1167         @ARGV or die "Please give project name on command line.\n";
1168         @ARGV == 1 or die_usage;
1169         my $project = get_project($ARGV[0]); # for safety only names accepted here
1170         my $projname = $project->{name};
1171         my $isempty = !$project->{mirror} && $project->is_empty;
1172         if (!$project->{mirror} && !$isempty && $reallydel) {
1173                 die "refusing to remove and delete non-empty push project without --force: $projname\n" unless $force;
1174                 warn "allowing removal and deletion of non-empty push project with --force\n" unless $quiet;
1175         }
1176         my $altwarn;
1177         my $removenogc;
1178         if ($project->has_forks) {
1179                 die "refusing to remove project with forks (use --keep-forks): $projname\n" unless $keepforks;
1180                 warn "allowing removal of forked project while preserving its forks with --keep-forks\n" unless $quiet;
1181                 # Run pseudo GC on that repository so that objects don't get lost within forks
1182                 my $basedir = $Girocco::Config::basedir;
1183                 my $projdir = $project->{path};
1184                 warn "We have to run pseudo GC on the repo so that the forks don't lose data. Hang on...\n" unless $quiet;
1185                 my $nogcrunning = sub {
1186                         die "Error: GC appears to be currently running on $projname\n"
1187                                 if -e "$projdir/gc.pid" || -e "$projdir/.gc_in_progress";
1188                 };
1189                 &$nogcrunning;
1190                 $removenogc = ! -e "$projdir/.nogc";
1191                 recreate_file("$projdir/.nogc") if $removenogc;
1192                 die "unable to create \"$projdir/.nogc\"\n" unless -e "$projdir/.nogc";
1193                 delete $ENV{show_progress};
1194                 $ENV{'show_progress'} = 1 unless $quiet;
1195                 sleep 2; # *cough*
1196                 &$nogcrunning;
1197                 system("$basedir/toolbox/perform-pre-gc-linking.sh", "--include-packs", $projname) == 0
1198                         or die "Running pseudo GC on project $projname failed\n";
1199                 $altwarn = 1;
1200         }
1201         my $archived;
1202         if (!$project->{mirror} && !$isempty && !$reallydel) {
1203                 $archived = $project->archive_and_delete;
1204                 unlink("$archived/.nogc") if $removenogc && defined($archived) && $archived ne "";
1205         } else {
1206                 $project->delete;
1207         }
1208         warn "Project '$projname' removed from $Girocco::Config::name" .
1209                 ($archived ? ", backup in '$archived'" : "") .".\n" unless $quiet;
1210         warn "Retained forks may now have unwanted objects/info/alternates lines\n" if $altwarn && !$quiet;
1211         return 0;
1212 }
1213
1214 sub cmd_prune {
1215         my ($force, $dryrun);
1216         parse_options(force => \$force, "dry-run" => \$dryrun, "quiet" => \$quiet);
1217         ($force && !$dryrun) || (!$force && $dryrun) or die_usage;
1218         my @projs = @ARGV;
1219         my %allprojs = map({($$_[0] => $_)} Girocco::Project::get_full_list_extended());
1220         my @allprojs = sort({lc($a) cmp lc($b) || $a cmp $b} keys(%allprojs));
1221         my %seen = ();
1222         @projs or @projs = @allprojs;
1223         my $bd = $Girocco::Config::reporoot.'/';
1224         my @remove = ();
1225         foreach (@projs) {
1226                 !$seen{$_} && $allprojs{$_} && ${$allprojs{$_}}[2] >= 65536 or next;
1227                 $seen{$_} = 1;
1228                 /^[a-zA-Z0-9]/ or next;
1229                 my $pd = $bd . $_ . '.git';
1230                 if (! -e $pd) {
1231                         warn "$_: no such directory: $pd\n" unless $quiet;
1232                         push(@remove, $_);
1233                 } elsif (! -d _) {
1234                         warn "$_: exists but not directory: $pd\n" unless $quiet;
1235                         push(@remove, $_);
1236                 }
1237         }
1238         warn "\n" if @remove && !$quiet;
1239         if ($dryrun) {
1240                 return 0 unless @remove;
1241                 my $msg = "Would remove ".scalar(@remove). " project entr";
1242                 $msg .= (@remove == 1 ? "y" : "ies");
1243                 $msg .= ":\n";
1244                 $msg .= join("", map("\t$_\n", @remove));
1245                 print $msg unless $quiet;
1246                 return 1;
1247         }
1248         my $msg = "Removed ".scalar(@remove). " project entr";
1249         $msg .= (@remove == 1 ? "y" : "ies");
1250         $msg .= ":\n";
1251         $msg .= join("", map("\t$_\n", @remove));
1252         my %remove = map({$_ => 1} @remove);
1253         filedb_atomic_edit(jailed_file('/etc/group'), sub {
1254                 my ($name,undef,$gid) = split /:/;
1255                 $gid =~ /^\d+$/ && $gid >= 65536 or return $_;
1256                 $name =~ /^[a-zA-Z0-9]/ or return $_;
1257                 !exists($remove{$name}) and return $_;
1258         });
1259         print $msg unless $quiet;
1260         return 0;
1261 }
1262
1263 sub cmd_show {
1264         use Data::Dumper;
1265         @ARGV <= 1 or die_usage;
1266         my $project = get_clean_project_gently($ARGV[0]);
1267         defined($project) or die_usage;
1268         my %info = %$project;
1269         my $d = Data::Dumper->new([\%info], ['*'.$project->{name}]);
1270         $d->Sortkeys(sub {[sort({lc($a) cmp lc($b)} keys %{$_[0]})]});
1271         print $d->Dump([\%info], ['*'.$project->{name}]);
1272         return 0;
1273 }
1274
1275 sub cmd_verify {
1276         my $dirfp = 0;
1277         parse_options("quiet" => \$quiet, "dir" => \$dirfp, "directory" => \$dirfp, "git-dir" =>\$dirfp);
1278         @ARGV <= 1 or die_usage;
1279         my $project = undef;
1280         my $pname = undef;
1281         eval {
1282                 $project = get_project_harder(@ARGV >= 1 ? $ARGV[0] : ".");
1283         };
1284         @ARGV > 0 || reftype($project) eq 'HASH' or die_usage;
1285         my $parg = @ARGV ? $ARGV[0] : $$project{name};
1286         $pname = $project->{name} if reftype($project) eq 'HASH';
1287         defined($pname) && $pname ne "" or $project = undef;
1288         !$@ && reftype($project) ne 'HASH' and $@ = "No such project: \"$parg\"\n";
1289         warn $@ if $@ && !$quiet;
1290         exit 1 if $@;
1291         $dirfp && defined($project->{path}) && $project->{path} ne "" and
1292                 $pname = $project->{path};
1293         printf "%s\n", $pname;
1294         return 0;
1295 }
1296
1297 sub get_worktrees {
1298         my $gd = shift;
1299         return () unless -d "$gd/worktrees";
1300         opendir my $dh, "$gd/worktrees" or return ();
1301         my @dirs = grep { !/^\.\.?$/ && -d "$gd/worktrees/$_"} readdir($dh);
1302         closedir $dh;
1303         my @wt = ();
1304         foreach (@dirs) {
1305                 open my $hd, '<', "$gd/worktrees/$_/HEAD" or next;
1306                 my $hh = <$hd>;
1307                 close $hd;
1308                 defined($hh) or next;
1309                 chomp($hh);
1310                 if ($hh =~ /^[0-9a-f]{40,}$/) {
1311                         push(@wt, [$_, $hh]);
1312                 } elsif ($hh =~ m{^ref:\s?(refs/heads/.+)$}) {
1313                         push(@wt, [$_, $1]);
1314                 }
1315         }
1316         return @wt;
1317 }
1318
1319 sub cmd_worktree {
1320         eval '$Girocco::Config::var_have_git_250' or die "worktree requires Git 2.5.0 or later\n";
1321         my $force;
1322         parse_options("force" => \$force, quiet => \$quiet, q =>\$quiet);
1323         my $project = get_project_harder_gently($ARGV[0]);
1324         defined($project) or die_usage;
1325         shift @ARGV if @ARGV;
1326         @ARGV or push(@ARGV, "list");
1327         my $gd = $project->{path};
1328         defined($gd) && -d $gd or die "Project \"$$project{name}\" does not actually exist\n";
1329         if ($project->{mirror}) {
1330                 die "Cannot use worktree command on mirror project\n" unless $force;
1331                 warn "Continuing with --force even though project is a mirror\n" unless $quiet;
1332         }
1333         my $symref = undef;
1334         my $mthash = undef;
1335         my $wantdwimadd = 0;
1336         my $hb = $project->{HEAD};
1337         defined($hb) or $hb = "";
1338         $hb !~ /^\[/ or $hb = "";
1339         if ($ARGV[0] eq "add" && (@ARGV == 2 && $ARGV[1] !~ /^-/ ||
1340                                   @ARGV == 3 && $ARGV[1] !~ /^-/ && $hb && $ARGV[2] eq $hb)) {{
1341                 $wantdwimadd = -1;
1342                 # Only "add" subcommand has special handling
1343                 my $isbare = get_git_chomp("--git-dir=".$gd, "rev-parse", "--is-bare-repository");
1344                 defined($isbare) && $isbare eq "true" or last; # only for bare repos
1345                 $symref = get_git_chomp("--git-dir=".$gd, "symbolic-ref", "-q", "HEAD");
1346                 defined($symref) && $symref =~ m{^refs/heads/.} or last; # only if symref HEAD
1347                 !grep({$$_[1] eq $symref} get_worktrees($gd)) or last; # and not checked out
1348                 if (get_git_chomp("--git-dir=".$gd, "rev-parse", "--verify", "-q", $symref)) {
1349                         # easy case, branch already exists, just add its name to arg list
1350                         push(@ARGV, substr($symref, 11)) unless @ARGV == 3;
1351                         $symref = undef;
1352                         $wantdwimadd = 1;
1353                 } else {
1354                         # nasty workaround for broken worktree command
1355                         my $mttree = get_git_chomp("--git-dir=".$gd, "mktree");
1356                         defined($mttree) && $mttree =~ /^[0-9a-f]{40,}$/ or last;
1357                         my $now = time();
1358                         my $cmt = "tree $mttree\nauthor - <-> $now +0000\ncommitter - <-> $now +0000\n\n";
1359                         my ($st, $rslt) = capture_command(1, $cmt, $Girocco::Config::git_bin,
1360                                 "--git-dir=".$gd, "hash-object", "-t", "commit", "-w", "--stdin");
1361                         defined($st) && $st == 0 && defined($rslt) or last;
1362                         chomp($rslt);
1363                         $rslt =~ /^[0-9a-f]{40,}$/ or last;
1364                         $mthash = $rslt;
1365                         pop(@ARGV) if @ARGV == 3;
1366                         push(@ARGV, $mthash);  # requires ugly fixup afterwards
1367                         $wantdwimadd = 2;
1368                 }
1369         }}
1370         warn $project->{name}, ": cannot DWIM worktree add (check `worktree list` output)\n"
1371                 if $wantdwimadd == -1 && !$quiet;
1372         my $saveHOME = $ENV{HOME};
1373         if (defined($origHOME) && $origHOME ne "" && $origHOME =~ m{^(/.+)$} && -d $1) {
1374                 $ENV{HOME} = $1;
1375         }
1376         my $ec = system($Girocco::Config::git_bin, "--git-dir=".$gd, "worktree", @ARGV);
1377         $ENV{HOME} = $saveHOME;
1378         if (defined($ec) && $ec == 0 && defined($symref) && defined($mthash)) {
1379                 # ugly fixup time
1380                 foreach (map($$_[0], grep({$$_[1] eq $mthash} get_worktrees($gd)))) {
1381                         open my $hf, '>', "$gd/worktrees/$_/HEAD" or next;
1382                         print $hf "ref: $symref\n";
1383                         close $hf;
1384                 }
1385         }
1386         defined($ec) && $ec != -1 or return 1;
1387         return ($ec >> 8);
1388 }
1389
1390 sub cmd_urls {
1391         my ($pushonly, $bundle);
1392         parse_options("push" => \$pushonly, "bundle" => \$bundle, "bundles" => \$bundle);
1393         $pushonly && $bundle and die "--push and --bundle are incompatible\n";
1394         my @projs = @ARGV;
1395         @ARGV <= 1 or die_usage;
1396         my $project = get_project_harder_gently($ARGV[0]);
1397         defined($project) or die_usage;
1398         my $suffix = "/".$project->{name}.".git";
1399         if ($bundle) {
1400                 my $bub = $Girocco::Config::httpbundleurl;
1401                 defined($bub) && $bub ne "" or return 0;
1402                 $bub =~ s{/$}{};
1403                 $bub .= $suffix . "/";
1404                 foreach ($project->bundles) {
1405                         print $bub, $_->[1], "\n";
1406                 }
1407                 return 0;
1408         }
1409         @Gitweb::Config::git_base_url_list = ();
1410         @Gitweb::Config::git_base_push_urls = ();
1411         @Gitweb::Config::git_base_mirror_urls = ();
1412         {
1413                 package Gitweb::Config;
1414                 if (!defined(do $Girocco::Config::basedir."/gitweb/gitweb_config.perl")) {
1415                         !$! or die "could not read gitweb_config.perl: $!\n";
1416                         !$@ or die "could not parse gitweb_config.perl: $@\n";
1417                 }
1418         }
1419         my @fetch_urls = ();
1420         my @push_urls = ();
1421         my $add_url = sub {
1422                 my $array = shift;
1423                 foreach (@_) {
1424                         if (ref($_)) {
1425                                 ref($_) eq 'ARRAY' or die "expected ARRAY ref";
1426                                 my $u = $$_[0];
1427                                 defined($u) && $u ne "" and
1428                                         push(@$array, $u.$suffix);
1429                         } elsif (defined($_) && $_ ne "") {
1430                                 push(@$array, $_.$suffix);
1431                         }
1432                 }
1433         };
1434         my $uniq = sub {
1435                 my %items = ();
1436                 $items{$_} = 1 foreach @_;
1437                 sort(keys(%items));
1438         };
1439         &$add_url(\@fetch_urls, @Gitweb::Config::git_base_url_list);
1440         if ($project->{mirror}) {
1441                 &$add_url(\@fetch_urls, @Gitweb::Config::git_base_mirror_urls);
1442         } else {
1443                 &$add_url(\@push_urls, @Gitweb::Config::git_base_push_urls);
1444         }
1445         my @urls = ();
1446         if ($pushonly) {
1447                 push(@urls, &$uniq(@push_urls));
1448         } else {
1449                 push(@urls, &$uniq(@fetch_urls, @push_urls));
1450         }
1451         print map "$_\n", @urls;
1452         return 0;
1453 }
1454
1455 sub cmd_listheads {
1456         @ARGV <= 1 or die_usage;
1457         my $project = get_project_harder_gently($ARGV[0]);
1458         defined($project) or die_usage;
1459         my @heads = sort({lc($a) cmp lc($b)} $project->get_heads);
1460         my $cur = $project->{HEAD};
1461         defined($cur) or $cur = '';
1462         my $curmark = '*';
1463         my $headhash = get_git("--git-dir=$project->{path}", 'rev-parse', '--quiet', '--verify', 'HEAD');
1464         defined($headhash) or $headhash = '';
1465         chomp $headhash;
1466         $headhash or $curmark = '!';
1467         foreach (@heads) {
1468                 my $mark = $_ eq $cur ? $curmark : ' ';
1469                 print "$mark $_\n";
1470         }
1471         return 0;
1472 }
1473
1474 sub is_cache_valid {
1475         local $_ = $_[0];
1476         defined($_) or return 0;
1477         ref($_) eq "ARRAY" or return 0;
1478         @$_ == 2 or return 0;
1479         defined($$_[0]) or return 0;
1480         defined($$_[1]) or return 0;
1481         !ref($$_[0]) or return 0;
1482         $$_[0] =~ /^Gitweb Cache Format 3.*$/ or return 0;
1483         ref($$_[1]) eq "ARRAY" or return 0;
1484         $_ = $$_[1];
1485         @$_ == 2 or return 0;
1486         defined($$_[0]) or return 0;
1487         defined($$_[1]) or return 0;
1488         ref($$_[0]) eq "ARRAY" or return 0;
1489         ref($$_[1]) eq "HASH" or return 0;
1490         my $cntprjs = () = grep({ref($_) eq "HASH"} @{$$_[0]});
1491         $cntprjs == @{$$_[0]} or return 0;
1492         return 1;
1493 }
1494
1495 sub cmd_listalltags {
1496         use Time::Local; # already use'd by Util.pm, this just brings in defs
1497         my ($info, $prjnms, $cnts, $ic, $rregex) = (0, 0, 0, undef);
1498         parse_options("cache-info" => \$info, "info" => \$info,
1499                 "projects" => \$prjnms, "counts" => \$cnts,
1500                 "ignore-case" => \$ic, "i" => \$ic,
1501                 ":filter" => \$rregex);
1502         $info && ($prjnms || $cnts || defined($rregex) || @ARGV > 0)
1503                 and die_usage;
1504         require Storable;
1505         my $gwic = $Girocco::Config::projlist_cache_dir . "/gitweb.index.cache";
1506         my $cache;
1507         if ($info) {
1508                 print "# Update cache with $Girocco::Config::basedir/jobs/gitwebcache.sh\n";
1509                 print "Location: $gwic\n";
1510                 if (-e $gwic && -f _ && -s _) {
1511                         my ($sz, $mt) = (stat $gwic)[7,9];
1512                         defined($mt) && $mt ne "" && defined($sz) && $sz > 0 or do {
1513                                 print "Status:   unable to stat cache file\n";
1514                                 return 0;
1515                         };
1516                         my ($sec,$min,$hour,$mday,$mon,$year) = localtime($mt);
1517                         $year += 1900;
1518                         my $gmtoff = timegm($sec,$min,$hour,$mday,$mon,$year) - $mt;
1519                         my $z = ($gmtoff >= 0 ? "+" : "-") .
1520                                 sprintf("%02d%02d", int(abs($gmtoff)/3600),
1521                                         int((abs($gmtoff)%3600)/60));
1522                         my $ago = "";
1523                         my $old = time() - $mt;
1524                         $old >= 0 and $ago = " (" . human_duration($old) . " ago)";
1525                         printf "Modified: %04d-%02d-%02d %02d:%02d:%02d %s%s\n",
1526                                 $year, $mon+1, $mday, $hour, $min, $sec, $z, $ago;
1527                         printf "Length:   %d byte%s\n", $sz, ($sz==1?"":"s");
1528                         my $loads = 0;
1529                         eval { $cache = Storable::retrieve($gwic); 1; } and $loads = 1;
1530                         print "Loadable: ", ($loads ? "yes" : "no"), "\n";
1531                         my $valid = is_cache_valid($cache);
1532                         print "Format:   ", ($valid ? $$cache[0] : "invalid"), "\n";
1533                         if ($valid) {
1534                                 my $idx = ${$$cache[1]}[1];
1535                                 print "Projects: ", scalar(keys(%$idx)), "\n";
1536                         }
1537                 } else {
1538                         print "Status:   does not exist, is not a readable file or is 0 bytes\n";
1539                 }
1540                 return 0;
1541         }
1542         my $regex = undef;
1543         if (defined($rregex)) {
1544                 eval { $regex = ($ic ? qr($rregex)i : qr($rregex)); 1; } or
1545                         die "bad regex \"$rregex\"\n".$@;
1546         }
1547         eval { $cache = Storable::retrieve($gwic); 1; } && is_cache_valid($cache) or
1548                 die "Could not load cache file (try listalltags --cache-info)\n";
1549         my $idx = ${$$cache[1]}[1];
1550         my %seen = ();
1551         my %limit = ();
1552         foreach (@ARGV) {
1553                 s/\.git$//i;
1554                 $_ ne "" or next;
1555                 $seen{$_.".git"} and next;
1556                 $seen{$_.".git"} = 1;
1557                 if (exists($$idx{$_.".git"})) {
1558                         $limit{$_.".git"} = 1;
1559                 } else {
1560                         warn "project not found in cache: $_\n";
1561                 }
1562         }
1563         @ARGV && !keys(%limit) and return 0; # nothing to do
1564         my @projlist = @ARGV ? keys(%limit) : keys(%$idx);
1565         my %gather = ();
1566         foreach (@projlist) {
1567                 my $p = $$idx{$_};
1568                 s/\.git$//;
1569                 while (my ($k,$v) = each(%{$p->{ctags}})) {
1570                         !defined($regex) || $k =~ /$regex/ or next;
1571                         $ic and $k = lc($k);
1572                         $v =~ /^\d+$/ && $v or $v = 1;
1573                         exists($gather{$k}) or
1574                                 $gather{$k} = [0, {}];
1575                         $gather{$k}->[0] += $v;
1576                         $gather{$k}->[1]->{$_} += $v;
1577                 }
1578         }
1579         my @taglist = sort({lc($a) cmp lc($b) || $a cmp $b} keys(%gather));
1580         foreach (@taglist) {
1581                 if ($cnts) {
1582                         print $_, "\t", $gather{$_}->[0], "\n";
1583                 } else {
1584                         print "$_\n";
1585                 }
1586                 if ($prjnms) {
1587                         foreach my $p (sort({lc($a) cmp lc($b) || $a cmp $b}
1588                                         keys(%{$gather{$_}->[1]}))) {
1589                                 if ($cnts) {
1590                                         printf "  %5d %s\n",
1591                                                 $gather{$_}->[1]->{$p}, $p;
1592                                 } else {
1593                                         print "  $p\n";
1594                                 }
1595                         }
1596                 }
1597         }
1598         return 0;
1599 }
1600
1601 sub cmd_listtags {
1602         my $vcnt = 0;
1603         parse_options("verbose" => \$vcnt, "v" => \$vcnt);
1604         @ARGV <= 1 or die_usage;
1605         my $project = get_project_harder_gently($ARGV[0]);
1606         defined($project) or die_usage;
1607         if ($vcnt) {
1608                 print map("$$_[0]\t$$_[1]\n", get_ctag_counts($project));
1609         } else {
1610                 print map("$_\n", $project->get_ctag_names);
1611         }
1612         return 0;
1613 }
1614
1615 sub cmd_deltags {
1616         my $ic = 0;
1617         parse_options("ignore-case" => \$ic, "i" => \$ic);
1618         @ARGV >= 2 or die_usage;
1619         my $project = get_project_harder(shift @ARGV);
1620         my %curtags;
1621         if ($ic) {
1622                 push(@{$curtags{lc($_)}}, $_) foreach $project->get_ctag_names;
1623         } else {
1624                 push(@{$curtags{$_}}, $_) foreach $project->get_ctag_names;
1625         }
1626         my @deltags = ();
1627         my %seentag = ();
1628         my $ctags = join(" ", @ARGV);
1629         $ctags = lc($ctags) if $ic;
1630         foreach (split(/[\s,]+/, $ctags)) {
1631                 next unless exists($curtags{$_});
1632                 $seentag{$_}=1, push(@deltags, $_) unless $seentag{$_};
1633         }
1634         if (!@deltags) {
1635                 warn $project->{name}, ": skipping removal of only non-existent tags\n" unless $quiet;
1636         } else {
1637                 # Avoid touching anything other than the ctags
1638                 foreach my $tg (@deltags) {
1639                         $project->delete_ctag($_) foreach @{$curtags{$tg}};
1640                 }
1641                 $project->_set_changed;
1642                 $project->_set_forkchange;
1643                 warn $project->{name}, ": specified tags have been removed\n" unless $quiet;
1644         }
1645         return 0;
1646 }
1647
1648 sub cmd_addtags {
1649         @ARGV >= 2 or die_usage;
1650         my $project = get_project_harder(shift @ARGV);
1651         my $ctags = join(" ", @ARGV);
1652         $ctags =~ /[^, a-zA-Z0-9:.+#_-]/ and
1653                 die "Content tag(s) \"$ctags\" contain(s) evil character(s).\n";
1654         my $oldmask = umask();
1655         umask($oldmask & ~0060);
1656         my $changed = 0;
1657         foreach (split(/[\s,]+/, $ctags)) {
1658                 ++$changed if $project->add_ctag($_, 1);
1659         }
1660         if ($changed) {
1661                 $project->_set_changed;
1662                 $project->_set_forkchange;
1663         }
1664         umask($oldmask);
1665         my $cnt = ($changed == 1) ? "1 content tag has" : $changed . " content tags have";
1666         warn $project->{name}, ": $cnt been added/updated\n" unless $quiet;
1667         return 0;
1668 }
1669
1670 sub _get_random_val {
1671         my $p = shift;
1672         my $md5;
1673         {
1674                 no warnings;
1675                 $md5 = md5_hex(time . $$ . rand() . join(':',%$p));
1676         }
1677         $md5;
1678 }
1679
1680 sub cmd_chpass {
1681         my $force = 0;
1682         parse_options("force" => \$force);
1683         my $random = undef;
1684         pop(@ARGV), $random=lc($ARGV[1]) if @ARGV==2 && $ARGV[1] =~ /^(?:random|unknown)$/i;
1685         @ARGV == 1 or die_usage;
1686         my $project = get_project_harder($ARGV[0]);
1687         die "refusing to change locked password of project \"$ARGV[0]\" without --force\n"
1688                 if $project->is_password_locked;
1689         my ($newpw, $rmsg);
1690         if ($random) {
1691                 if ($random eq "random") {
1692                         die "refusing to set random password without --force\n" unless $force;
1693                         $rmsg = "set to random value";
1694                         $newpw = _get_random_val($project);
1695                 } else {
1696                         die "refusing to set password hash to '$random' without --force\n" unless $force;
1697                         $rmsg = "hash set to '$random'";
1698                         $newpw = $random;
1699                 }
1700         } else {
1701                 $rmsg = "updated";
1702                 if (-t STDIN) {
1703                         print "Changing admin password for project $ARGV[0]\n";
1704                         my $np1 = prompt_noecho_nl_or_die("New password for project $ARGV[0] (echo is off)");
1705                         $np1 ne "" or die "empty passwords are not permitted (brokenness will ensue)\n";
1706                         my $np2 = prompt_noecho_nl_or_die("Retype new password for project $ARGV[0]");
1707                         $np1 eq $np2 or die "Our high-paid security consultants have determined that\n" .
1708                                 "the admin passwords you have entered do not match each other.\n";
1709                         $newpw = $np1;
1710                 } else {
1711                         $newpw = <STDIN>;
1712                         defined($newpw) or die "missing new password on STDIN\n";
1713                         chomp($newpw);
1714                 }
1715         }
1716         $newpw ne "" or die "empty passwords are not permitted (brokenness will ensue)\n";
1717         my $old = $project->{crypt};
1718         $project->{crypt} = (defined($random) && $random ne "random") ? $newpw : scrypt_sha1($newpw);
1719         if (defined($old) && $old eq $project->{crypt}) {
1720                 warn $project->{name}, ": skipping update of password hash to same value\n" unless $quiet;
1721         } else {
1722                 # Avoid touching anything other than the password hash
1723                 $project->_group_update;
1724                 warn $project->{name}, ": admin password $rmsg (new hash stored)\n" unless $quiet;
1725         }
1726         return 0;
1727 }
1728
1729 sub cmd_checkpw {
1730         @ARGV <= 1 or die_usage;
1731         my $project = get_project_harder_gently($ARGV[0]);
1732         defined($project) or die_usage;
1733         my $pwhash = $project->{crypt};
1734         defined($pwhash) or $pwhash = "";
1735         if ($pwhash eq "") {
1736                 warn $project->{name}, ": no password required\n" unless $quiet;
1737                 return 0;
1738         }
1739         if ($project->is_password_locked) {
1740                 warn $project->{name}, ": password is locked\n" unless $quiet;
1741                 exit 1;
1742         }
1743         my $checkpw;
1744         if (-t STDIN) {
1745                 $checkpw = prompt_noecho_nl_or_die("Admin password for project $$project{name} (echo is off)");
1746                 $checkpw ne "" or warn "checking for empty password as hash (very unlikely)\n" unless $quiet;
1747         } else {
1748                 $checkpw = <STDIN>;
1749                 defined($checkpw) or die "missing admin password on STDIN\n";
1750                 chomp($checkpw);
1751         }
1752         unless (Girocco::CLIUtil::check_passwd_match($pwhash, $checkpw)) {
1753                 warn "password check failure\n" unless $quiet;
1754                 exit 1;
1755         }
1756         warn "admin password match\n" unless $quiet;
1757         return 0;
1758 }
1759
1760 sub cmd_gc {
1761         my ($force, $auto, $redelta, $recompress, $aggressive);
1762         parse_options(force => \$force, quiet => \$quiet, q => \$quiet, auto => \$auto,
1763                 redelta => \$redelta, "no-reuse-delta" => \$redelta, aggressive => \$force,
1764                 recompress => \$recompress, "no-reuse-object" => $recompress,
1765                 aggressive => \$aggressive);
1766         $aggressive and $force = $redelta = 1;
1767         $force && $auto and die "--force and --auto are mutually exclusive options\n";
1768         @ARGV <= 1 or die_usage;
1769         my $project = get_project_harder_gently($ARGV[0]);
1770         defined($project) or die "Please give project name on command line.\n";
1771         delete $ENV{show_progress};
1772         delete $ENV{force_gc};
1773         $quiet or $ENV{"show_progress"} = 1;
1774         $force and $ENV{"force_gc"} = 1;
1775         if (!$auto && !$force && ! -e $project->{path}."/.needsgc") {
1776                 open NEEDSGC, '>', $project->{path}."/.needsgc" and close NEEDSGC;
1777         }
1778         my @args = ($Girocco::Config::basedir . "/jobd/gc.sh", $project->{name});
1779         $redelta && !$recompress and push(@args, "-f");
1780         $recompress and push(@args, "-F");
1781         my $lastgc = $project->{lastgc};
1782         system({$args[0]} @args) != 0 and return 1;
1783         # Do it again Sam, but only if lastgc was set, gc.sh succeeded and now it's not set
1784         if ($lastgc) {
1785                 my $newlastgc = get_git("--git-dir=$project->{path}", 'config', '--get', 'gitweb.lastgc');
1786                 if (!$newlastgc) {
1787                         system({$args[0]} @args) != 0 and return 1;
1788                 }
1789         }
1790         return 0;
1791 }
1792
1793 sub cmd_update {
1794         my ($force, $summary);
1795         parse_options(force => \$force, quiet => \$quiet, q => \$quiet, summary => \$summary);
1796         $quiet && $summary and die "--quiet and --summary are mutually exclusive options\n";
1797         @ARGV <= 1 or die_usage;
1798         my $project = get_project_harder_gently($ARGV[0]);
1799         defined($project) or die "Please give project name on command line.\n";
1800         $project->{mirror} or die "Project \"$$project{name}\" is a push project, not a mirror project.\n";
1801         delete $ENV{show_progress};
1802         delete $ENV{force_update};
1803         if ($quiet) {
1804                 $ENV{"show_progress"} = 0;
1805         } else {
1806                 $ENV{"show_progress"} = ($summary ? 1 : 2);
1807         }
1808         $force and $ENV{"force_update"} = 1;
1809         system($Girocco::Config::basedir . "/jobd/update.sh", $project->{name}) != 0 and return 1;
1810         return 0;
1811 }
1812
1813 sub cmd_remirror {
1814         my $force = 0;
1815         parse_options(force => \$force, quiet => \$quiet, q => \$quiet);
1816         @ARGV or die "Please give project name on command line.\n";
1817         @ARGV == 1 or die_usage;
1818         my $project = get_project_harder($ARGV[0]);
1819         $project->{mirror} or die "Project \"$ARGV[0]\" is a push project, not a mirror project.\n";
1820         if ($project->{clone_in_progress} && !$project->{clone_failed}) {
1821                 warn "Project \"$ARGV[0]\" already seems to have a clone underway at this moment.\n" unless $quiet && $force;
1822                 exit(255) unless $force;
1823                 yes_to_continue_or_die("Are you sure you want to force a remirror");
1824         }
1825         unlink($project->_clonefail_path);
1826         unlink($project->_clonelog_path);
1827         recreate_file($project->_clonep_path);
1828         my $sock = IO::Socket::UNIX->new($Girocco::Config::chroot.'/etc/taskd.socket') or
1829                 die "cannot connect to taskd.socket: $!\n";
1830         select((select($sock),$|=1)[0]);
1831         $sock->print("clone ".$project->{name}."\n");
1832         # Just ignore reply, we are going to succeed anyway and the I/O
1833         # would apparently get quite hairy.
1834         $sock->flush();
1835         sleep 2; # *cough*
1836         $sock->close();
1837         warn "Project \"$ARGV[0]\" remirror initiated.\n" unless $quiet;
1838         return 0;
1839 }
1840
1841 sub cmd_setowner {
1842         my $force = 0;
1843         parse_options("force" => \$force);
1844         @ARGV == 2 || (@ARGV <= 1 && !$force && !$setopt) or die_usage;
1845         my $project = get_project_harder_gently($ARGV[0]);
1846         defined($project) or die_usage;
1847         if (@ARGV == 2 && !valid_email($ARGV[1])) {
1848                 die "invalid owner/email (use --force to accept): \"$ARGV[1]\"\n"
1849                         unless $force;
1850                 warn "using invalid owner/email with --force\n" unless $quiet;
1851         }
1852         if (@ARGV == 2 && length($ARGV[1]) > 96) {
1853                 die "owner/email longer than 96 chars (use --force to accept): \"$ARGV[1]\"\n"
1854                         unless $force;
1855                 warn "using longer than 96 char owner/email with --force\n" unless $quiet;
1856         }
1857         my $old = $project->{email};
1858         if (@ARGV <= 1) {
1859                 print "$old\n" if defined($old);
1860                 return 0;
1861         }
1862         if (defined($old) && $old eq $ARGV[1]) {
1863                 warn $project->{name}, ": skipping update of owner/email to same value\n" unless $quiet;
1864         } else {
1865                 # Avoid touching anything other than "gitweb.owner"
1866                 $project->_property_fput("email", $ARGV[1]);
1867                 $project->_update_index;
1868                 $project->_set_changed;
1869                 warn $project->{name}, ": owner/email updated to \"$ARGV[1]\"\n" unless $quiet;
1870         }
1871         return 0;
1872 }
1873
1874 sub cmd_setdesc {
1875         my $force = 0;
1876         parse_options("force" => \$force);
1877         @ARGV >= 2 || (@ARGV <= 1 && !$force && !$setopt) or die_usage;
1878         my $project = get_project_harder_gently($ARGV[0]);
1879         defined($project) or die_usage;
1880         shift(@ARGV) if @ARGV;
1881         if (@ARGV && !valid_desc(join(" ", @ARGV))) {
1882                 die "invalid description (use --force to accept): \"".join(" ", @ARGV)."\"\n"
1883                         unless $force;
1884                 warn "using invalid description with --force\n" unless $quiet;
1885         }
1886         my $desc = clean_desc(join(" ", @ARGV));
1887         if (@ARGV && length($desc) > 1024) {
1888                 die "description longer than 1024 chars (use --force to accept): \"$desc\"\n"
1889                         unless $force;
1890                 warn "using longer than 1024 char description with --force\n" unless $quiet;
1891         }
1892         my $old = $project->{desc};
1893         if (!@ARGV) {
1894                 print "$old\n" if defined($old);
1895                 return 0;
1896         }
1897         if (defined($old) && $old eq $desc) {
1898                 warn $project->{name}, ": skipping update of description to same value\n" unless $quiet;
1899         } else {
1900                 # Avoid touching anything other than description file
1901                 $project->_property_fput("desc", $desc);
1902                 $project->_set_changed;
1903                 warn $project->{name}, ": description updated to \"$desc\"\n" unless $quiet;
1904         }
1905         return 0;
1906 }
1907
1908 sub cmd_setreadme {
1909         my ($force, $readmetype) = (0, undef);
1910         parse_options(force => \$force, ":type" => \$readmetype, ":format" => \$readmetype);
1911         @ARGV == 1 && defined($readmetype) and push(@ARGV, undef);
1912         @ARGV == 2 || (@ARGV <= 1 && !$force && !defined($readmetype) && !$setopt) or die_usage;
1913         defined($readmetype) and $readmetype = Girocco::Project::_normalize_rmtype($readmetype,1);
1914         defined($readmetype) && !$readmetype and die_usage;
1915         my $project = get_project_harder_gently($ARGV[0]);
1916         defined($project) or die_usage;
1917         my $old = $project->{READMEDATA};
1918         if (@ARGV <= 1) {
1919                 chomp $old if defined($old);
1920                 print "$old\n" if defined($old) && $old ne "";
1921                 return 0;
1922         }
1923         $readmetype or $readmetype = $project->{rmtype};
1924         my ($new, $raw, $newname);
1925         $newname = '';
1926         if (!defined($ARGV[1])) {
1927                 $new = $old;
1928                 $newname = "original README data";
1929                 $readmetype ne $project->{rmtype} && $new ne "" and $raw = 1;
1930         } elsif ($ARGV[1] eq "-") {
1931                 local $/;
1932                 $new = <STDIN>;
1933                 $raw = 1;
1934                 $newname = "contents of <STDIN>";
1935         } elsif (lc($ARGV[1]) eq "automatic" || lc($ARGV[1]) eq "auto") {
1936                 $new = "";
1937         } elsif (lc($ARGV[1]) eq "suppressed" || lc($ARGV[1]) eq "suppress") {
1938                 $new = "<!-- suppress -->";
1939         } else {
1940                 my $fn = $ARGV[1];
1941                 $fn =~ s/^\@//;
1942                 die "missing filename for README\n" unless $fn ne "";
1943                 die "no such file: \"$fn\"\n" unless -f $fn && -r $fn;
1944                 open F, '<', $fn or die "cannot open \"$fn\" for reading: $!\n";
1945                 local $/;
1946                 $new = <F>;
1947                 close F;
1948                 $raw = 1;
1949                 $newname = "contents of \"$fn\"";
1950         }
1951         defined($new) or $new = '';
1952         my $origrmtype = $project->{rmtype};
1953         $project->{rmtype} = $readmetype;
1954         $project->{READMEDATA} = to_utf8($new, 1);
1955         $project->_cleanup_readme;
1956         if (length($project->{READMEDATA}) > 8192) {
1957                 die "readme greater than 8192 chars is too long (use --force to override)\n"
1958                         unless $force;
1959                 warn "using readme greater than 8192 chars with --force\n" unless $quiet;
1960         }
1961         if ($raw) {
1962                 my ($cnt, $err) = $project->_lint_readme(0);
1963                 if ($cnt) {
1964                         my $msg = "README: $cnt error";
1965                         $msg .= "s" unless $cnt == 1;
1966                         print STDERR "$msg\n", "-" x length($msg), "\n", $err
1967                                 unless $force && $quiet;
1968                         exit(255) unless $force && $project->{rmtype} eq 'HTML';
1969                         warn $project->{name} . ": using invalid raw HTML with --force\n" unless $quiet;
1970                         $project->{README} = $project->{READMEDATA};
1971                 }
1972         }
1973         if (defined($old) && $old eq $project->{READMEDATA} && $readmetype eq $origrmtype && !$force) {
1974                 warn $project->{name}, ": skipping update of README to same value\n" unless $quiet;
1975         } else {
1976                 # Avoid touching anything other than README.html file
1977                 $project->_property_fput("READMEDATA", $project->{READMEDATA}, 1);
1978                 $project->_property_fput("README", $project->{README});
1979                 $project->_property_fput("rmtype", $readmetype) if $readmetype ne $origrmtype;
1980                 $project->_set_changed;
1981                 my $desc = get_readme_desc($project->{README});
1982                 if ($newname) {
1983                         $newname .= " ($desc)";
1984                 } else {
1985                         $newname = $desc;
1986                 }
1987                 warn $project->{name}, ": README $readmetype format updated to $newname\n" unless $quiet;
1988         }
1989         return 0;
1990 }
1991
1992 sub valid_head {
1993         my ($proj, $newhead) = @_;
1994         my %okheads = map({($_ => 1)} $proj->get_heads);
1995         exists($okheads{$newhead});
1996 }
1997
1998 sub cmd_sethead {
1999         my $force = 0;
2000         parse_options(force => \$force);
2001         @ARGV == 2 || (@ARGV <= 1 && !$setopt) or die_usage;
2002         my $project = get_project_harder_gently($ARGV[0]);
2003         defined($project) or die_usage;
2004         if (@ARGV == 2 && !valid_head($project, $ARGV[1])) {
2005                 die "invalid head (try \"@{[basename($0)]} listheads $ARGV[0]\"): \"$ARGV[1]\"\n" unless $force;
2006                 valid_branch_name($ARGV[1]) or
2007                         die "grossly invalid new HEAD: $ARGV[1]\n";
2008                 warn "Continuing with --force even though requested branch does not exist\n" unless $quiet;
2009         }
2010         my $old = $project->{HEAD};
2011         if (@ARGV <= 1) {
2012                 print "$old\n" if defined($old);
2013                 return 0;
2014         }
2015         if (defined($old) && $old eq $ARGV[1]) {
2016                 warn $project->{name}, ": skipping update of HEAD symref to same value\n" unless $quiet;
2017         } else {
2018                 # Avoid touching anything other than the HEAD symref
2019                 $project->set_HEAD($ARGV[1]);
2020                 $project->_set_changed;
2021                 warn $project->{name}, ": HEAD symref updated to \"refs/heads/$ARGV[1]\"\n" unless $quiet;
2022         }
2023         return 0;
2024 }
2025
2026 sub cmd_sethooks {
2027         my $force = 0;
2028         parse_options(force => \$force);
2029         @ARGV == 2 || (@ARGV <= 1 && !$force && !$setopt) or die_usage;
2030         my $project = get_project_harder_gently($ARGV[0]);
2031         defined($project) or die_usage;
2032         my $projconfig = read_config_file_hash($project->{path}."/config");
2033         my $ghp = $Girocco::Config::reporoot."/_global/hooks";
2034         my $rghp = realpath($ghp);
2035         my $lhp = $project->{path}."/hooks";
2036         my $rlhp = realpath($lhp);
2037         my $ahp = "";
2038         my $rahp = undef;
2039         if (defined($projconfig) && defined($projconfig->{"core.hookspath"})) {
2040                 $ahp = $projconfig->{"core.hookspath"};
2041                 $rahp = realpath($ahp);
2042         }
2043         if (@ARGV <= 1) {
2044                 if (defined($rahp) && $rahp ne "") {
2045                         if ($rahp eq $rghp) {
2046                                 my $nc = ($ahp eq $ghp ? "" : " non-canonical");
2047                                 printf "%s \t(global%s)\n", $ahp, $nc;
2048                         } elsif ($rahp eq $rlhp) {
2049                                 my $nc = ($ahp eq $lhp ? "" : " non-canonical");
2050                                 printf "%s \t(local%s)\n", $ahp, $nc;
2051                         } elsif ($rahp ne $ahp) {
2052                                 print "$ahp \t($rahp)\n";
2053                         } else {
2054                                 print "$ahp\n";
2055                         }
2056                 } elsif ($ahp ne "") {
2057                         print "$ahp \t(non-existent)\n";
2058                 }
2059                 return 0;
2060         }
2061         my $shp = $ARGV[1];
2062         if (lc($shp) eq "global") {
2063                 $shp = $ghp;
2064         } elsif (lc($shp) eq "local") {
2065                 $shp = $lhp;
2066         } elsif (substr($shp, 0, 2) eq "~/") {
2067                 $shp = $ENV{"HOME"}.substr($shp,1);
2068         } elsif ($shp =~ m,^~([a-zA-Z_][a-zA-Z_0-9]*)((?:/.*)?)$,) {
2069                 my $sfx = $2;
2070                 my $hd = (getpwnam($1))[7];
2071                 $shp = $hd . $sfx if defined($hd) && $hd ne "" && $hd ne "/" && -d $hd;
2072         }
2073         $shp ne "" && -d $shp or die "no such directory: $ARGV[1]\n";
2074         my $rshp = realpath($shp);
2075         defined($rshp) && $rshp ne "" or die "could not realpath: $ARGV[1]\n";
2076         $rshp =~ m,^/[^/], or die "invalid hookspath: $rshp\n";
2077         die "refusing to switch from current non-global hookspath without --force\n"
2078                 if !$force && defined($rahp) && $rahp ne "" && $rahp ne $rghp && $rshp ne $rahp;
2079         if (!$force && defined($rahp) && $rahp ne "") {
2080                 if ($rshp eq $rahp && ($ahp eq $ghp || $ahp eq $lhp)) {
2081                         warn $project->{name}, ": skipping update of hookspath to same effective value\n" unless $quiet;
2082                         return 0;
2083                 }
2084         }
2085         $rshp = $ghp if $rshp eq $rghp;
2086         $rshp = $lhp if $rshp eq $rlhp;
2087         if ($rshp eq $ahp) {
2088                 warn $project->{name}, ": skipping update of hookspath to same value\n" unless $quiet;
2089                 return 0;
2090         }
2091         die "refusing to set neither local nor global hookspath without --force\n"
2092                 if !$force && $rshp ne $ghp && $rshp ne $lhp;
2093         system($Girocco::Config::git_bin, '--git-dir='.$project->{path},
2094                 'config', "core.hookspath", $rshp);
2095         my $newval = '"'.$rshp.'"';
2096         $newval = "global" if $rshp eq $ghp;
2097         $newval = "local" if $rshp eq $lhp;
2098         warn $project->{name}, ": hookspath set to $newval\n" unless $quiet;
2099         return 0;
2100 }
2101
2102 our %boolfields;
2103 BEGIN {
2104         %boolfields = (
2105                 cleanmirror   => 1,
2106                 reverseorder  => 0,
2107                 summaryonly   => 0,
2108                 statusupdates => 1,
2109         );
2110 }
2111
2112 sub cmd_setbool {
2113         my $force = 0;
2114         parse_options("force" => \$force);
2115         @ARGV == 3 || (@ARGV == 2 && !$force && !$setopt) or die_usage;
2116         my $project = get_project_harder($ARGV[0]);
2117         if (!exists($boolfields{$ARGV[1]})) {
2118                 die "invalid boolean field name: \"$ARGV[1]\" -- try \"help\"\n";
2119         }
2120         if (@ARGV == 3 && $boolfields{$ARGV[1]} && !$project->{mirror}) {
2121                 die "invalid boolean field for non-mirror (use --force to accept): \"$ARGV[1]\"\n"
2122                         unless $force;
2123                 warn "using mirror field on non-mirror with --force\n" unless $quiet;
2124         }
2125         if (@ARGV == 3 && !valid_bool($ARGV[2])) {
2126                 die "invalid boolean value: \"$ARGV[2]\"\n";
2127         }
2128         my $bool = clean_bool($ARGV[2]);
2129         my $old = $project->{$ARGV[1]};
2130         if (@ARGV == 2) {
2131                 print "$old\n" if defined($old);
2132                 return 0;
2133         }
2134         if (defined($old) && $old eq $bool) {
2135                 warn $project->{name}, ": skipping update of $ARGV[1] to same value\n" unless $quiet;
2136         } else {
2137                 # Avoid touching anything other than $ARGV[1] field
2138                 $project->_property_fput($ARGV[1], $bool);
2139                 warn $project->{name}, ": $ARGV[1] updated to $bool\n" unless $quiet;
2140         }
2141         return 0;
2142 }
2143
2144 sub cmd_setjsontype {
2145         @ARGV == 2 || (@ARGV <= 1 && !$setopt) or die_usage;
2146         my $project = get_project_harder_gently($ARGV[0]);
2147         defined($project) or die_usage;
2148         my $jsontype;
2149         if (@ARGV == 2) {
2150                 my $jt = lc($ARGV[1]);
2151                 index($jt, "/") >= 0 or $jt = "application/".$jt;
2152                 $jt eq 'application/x-www-form-urlencoded' ||
2153                 $jt eq 'application/json' or
2154                         die "invalid jsontype value: \"$ARGV[1]\"\n";
2155                 $jsontype = $jt;
2156         }
2157         my $old = $project->{jsontype};
2158         if (@ARGV <= 1) {
2159                 print "$old\n" if defined($old);
2160                 return 0;
2161         }
2162         if (defined($old) && $old eq $jsontype) {
2163                 warn $project->{name}, ": skipping update of jsontype to same value\n" unless $quiet;
2164         } else {
2165                 # Avoid touching anything other than jsontype field
2166                 $project->_property_fput('jsontype', $jsontype);
2167                 warn $project->{name}, ": jsontype updated to $jsontype\n" unless $quiet;
2168         }
2169         return 0;
2170 }
2171
2172 sub cmd_setjsonsecret {
2173         @ARGV == 2 || (@ARGV <= 1 && !$setopt) or die_usage;
2174         my $project = get_project_harder_gently($ARGV[0]);
2175         defined($project) or die_usage;
2176         my $jsonsecret;
2177         if (@ARGV == 2) {
2178                 my $js = $ARGV[1];
2179                 $js =~ s/^\s+//; $js =~ s/\s+$//;
2180                 $jsonsecret = $js;
2181         }
2182         my $old = $project->{jsonsecret};
2183         if (@ARGV <= 1) {
2184                 print "$old\n" if defined($old);
2185                 return 0;
2186         }
2187         if (defined($old) && $old eq $jsonsecret) {
2188                 warn $project->{name}, ": skipping update of jsonsecret to same value\n" unless $quiet;
2189         } else {
2190                 # Avoid touching anything other than jsonsecret field
2191                 $project->_property_fput('jsonsecret', $jsonsecret);
2192                 warn $project->{name}, ": jsonsecret updated to \"$jsonsecret\"\n" unless $quiet;
2193         }
2194         return 0;
2195 }
2196
2197 sub cmd_setautogchack {
2198         @ARGV == 2 || (@ARGV <= 1 && !$setopt) or die_usage;
2199         my $project = get_project_harder_gently($ARGV[0]);
2200         defined($project) or die_usage;
2201         my $aghok = $Girocco::Config::autogchack &&
2202                 ($project->{mirror} || $Girocco::Config::autogchack ne "mirror");
2203         my $old = defined($project->{autogchack}) ? clean_bool($project->{autogchack}) : "unset";
2204         if (@ARGV == 1) {
2205                 print "$old\n" if $aghok;
2206                 return 0;
2207         }
2208         my $bool;
2209         if (lc($ARGV[1]) eq "unset") {
2210                 $bool = "unset";
2211         } else {
2212                 valid_bool($ARGV[1]) or die "invalid boolean value: \"$ARGV[1]\"\n";
2213                 $bool = clean_bool($ARGV[1]);
2214         }
2215         if (!$aghok) {
2216                 die "\$Girocco::Config::autogchack is false\n" unless $Girocco::Config::autogchack;
2217                 die "\$Girocco::Config::autogchack is only enabled for mirrors\n";
2218         }
2219         if ($old eq $bool) {
2220                 warn $project->{name}, ": autogchack value unchanged\n" unless $quiet;
2221         } else {
2222                 if ($bool eq "unset") {
2223                         system($Girocco::Config::git_bin, '--git-dir='.$project->{path},
2224                                 'config', '--unset', "girocco.autogchack");
2225                 } else {
2226                         system($Girocco::Config::git_bin, '--git-dir='.$project->{path},
2227                                 'config', '--bool', "girocco.autogchack", $bool);
2228                 }
2229         }
2230         return system($Girocco::Config::basedir . "/jobd/maintain-auto-gc-hack.sh", $project->{name}) == 0
2231                 ? 0 : 1;
2232 }
2233
2234 sub valid_url {
2235         my ($url, $type) = @_;
2236         $type ne 'baseurl' and return valid_web_url($url);
2237         valid_repo_url($url) or return 0;
2238         if ($Girocco::Config::restrict_mirror_hosts) {
2239                 my $mh = extract_url_hostname($url);
2240                 is_dns_hostname($mh) or return 0;
2241                 !is_our_hostname($mh) or return 0;
2242         }
2243         return 1;
2244 }
2245
2246 our %urlfields;
2247 BEGIN {
2248         %urlfields = (
2249                 baseurl    => ["url"       , 1],
2250                 homepage   => ["hp"        , 0],
2251                 notifyjson => ["notifyjson", 0],
2252         );
2253 }
2254
2255 sub cmd_seturl {
2256         my $force = 0;
2257         parse_options("force" => \$force);
2258         @ARGV == 3 || (@ARGV == 2 && !$force && !$setopt) or die_usage;
2259         my $project = get_project_harder($ARGV[0]);
2260         if (!exists($urlfields{$ARGV[1]})) {
2261                 die "invalid URL field name: \"$ARGV[1]\" -- try \"help\"\n";
2262         }
2263         if (@ARGV == 3 && ${$urlfields{$ARGV[1]}}[1] && !$project->{mirror}) {
2264                 die "invalid URL field for non-mirror (use --force to accept): \"$ARGV[1]\"\n"
2265                         unless $force;
2266                 warn "using mirror field on non-mirror with --force\n" unless $quiet;
2267         }
2268         if (@ARGV == 3 && !valid_url($ARGV[2], $ARGV[1])) {
2269                 die "invalid URL (use --force to accept): \"$ARGV[2]\"\n"
2270                         unless $force;
2271                 warn "using invalid URL with --force\n" unless $quiet;
2272         }
2273         my $old = $project->{${$urlfields{$ARGV[1]}}[0]};
2274         if (@ARGV == 2) {
2275                 print "$old\n" if defined($old);
2276                 return 0;
2277         }
2278         if (defined($old) && $old eq $ARGV[2]) {
2279                 warn $project->{name}, ": skipping update of $ARGV[1] to same value\n" unless $quiet;
2280         } else {
2281                 # Avoid touching anything other than $ARGV[1]'s field
2282                 $project->_property_fput(${$urlfields{$ARGV[1]}}[0], $ARGV[2]);
2283                 if ($ARGV[1] eq "baseurl") {
2284                         $project->{url} = $ARGV[2];
2285                         $project->_set_bangagain;
2286                 }
2287                 $project->_set_changed unless $ARGV[1] eq "notifyjson";
2288                 warn $project->{name}, ": $ARGV[1] updated to $ARGV[2]\n" unless $quiet;
2289         }
2290         return 0;
2291 }
2292
2293 our %msgsfields;
2294 BEGIN {
2295         %msgsfields = (
2296                 notifymail => 1,
2297                 notifytag  => 1,
2298         );
2299 }
2300
2301 sub cmd_setmsgs {
2302         my $force = 0;
2303         parse_options("force" => \$force);
2304         @ARGV >= 3 || (@ARGV == 2 && !$force && !$setopt) or die_usage;
2305         my $project = get_project_harder(shift @ARGV);
2306         my $field = shift @ARGV;
2307         if (!exists($msgsfields{$field})) {
2308                 die "invalid msgs field name: \"$field\" -- try \"help\"\n";
2309         }
2310         if (@ARGV && !valid_addrlist(@ARGV)) {
2311                 die "invalid email address list (use --force to accept): \"".join(" ",@ARGV)."\"\n"
2312                         unless $force;
2313                 warn "using invalid email address list with --force\n" unless $quiet;
2314         }
2315         my $old = $project->{$field};
2316         if (!@ARGV) {
2317                 printf "%s\n", clean_addrlist($old, " ") if defined($old);
2318                 return 0;
2319         }
2320         my $newlist = clean_addrlist(join(" ",@ARGV));
2321         if (defined($old) && $old eq $newlist) {
2322                 warn $project->{name}, ": skipping update of $field to same value\n" unless $quiet;
2323         } else {
2324                 # Avoid touching anything other than $field's field
2325                 $project->_property_fput($field, $newlist);
2326                 warn $project->{name}, ": $field updated to \"$newlist\"\n" unless $quiet;
2327         }
2328         return 0;
2329 }
2330
2331 sub cmd_setusers {
2332         my $force = 0;
2333         parse_options("force" => \$force);
2334         @ARGV >= 2 || (@ARGV <= 1 && !$force && !$setopt) or die_usage;
2335         my $project = get_project_harder_gently($ARGV[0]);
2336         defined($project) or die_usage;
2337         shift(@ARGV) if @ARGV;
2338         my $projname = $project->{name};
2339         !@ARGV || !$project->{mirror} or die "cannot set users list for mirror project: \"$projname\"\n";
2340         my @newusers = ();
2341         if (@ARGV) {
2342                 eval {@newusers = validate_users(join(" ", @ARGV), $force); 1;} or exit 255;
2343                 die "refusing to set empty users list without --force\n" unless @newusers || $force;
2344         }
2345         return 0 if !@ARGV && $project->{mirror};
2346         my $oldusers = $project->{users};
2347         if ($oldusers && ref($oldusers) eq "ARRAY") {
2348                 $oldusers = join("\n", @$oldusers);
2349         } else {
2350                 $oldusers = "";
2351         }
2352         if (!@ARGV) {
2353                 print "$oldusers\n" if $oldusers ne "";
2354                 return 0;
2355         }
2356         if ($oldusers eq join("\n", @newusers)) {
2357                 warn "$projname: skipping update of users list to same value\n" unless $quiet;
2358         } else {
2359                 # Avoid touching anything other than the users list
2360                 $project->{users} = \@newusers;
2361                 $project->_update_users;
2362                 warn "$projname: users list updated to \"@{[join(',',@newusers)]}\"\n" unless $quiet;
2363         }
2364         return 0;
2365 }
2366
2367 our %fieldnames;
2368 BEGIN {
2369         %fieldnames = (
2370                 owner         => [\&cmd_setowner,      0],
2371                 desc          => [\&cmd_setdesc,       0],
2372                 description   => [\&cmd_setdesc,       0],
2373                 readme        => [\&cmd_setreadme,     0],
2374                 head          => [\&cmd_sethead,       0],
2375                 HEAD          => [\&cmd_sethead,       0],
2376                 hooks         => [\&cmd_sethooks,      0],
2377                 hookspath     => [\&cmd_sethooks,      0],
2378                 cleanmirror   => [\&cmd_setbool,       1],
2379                 reverseorder  => [\&cmd_setbool,       1],
2380                 summaryonly   => [\&cmd_setbool,       1],
2381                 statusupdates => [\&cmd_setbool,       1],
2382                 autogchack    => [\&cmd_setautogchack, 0],
2383                 baseurl       => [\&cmd_seturl,        1],
2384                 homepage      => [\&cmd_seturl,        1],
2385                 notifyjson    => [\&cmd_seturl,        1],
2386                 jsontype      => [\&cmd_setjsontype,   0],
2387                 jsonsecret    => [\&cmd_setjsonsecret, 0],
2388                 notifymail    => [\&cmd_setmsgs,       1],
2389                 notifytag     => [\&cmd_setmsgs,       1],
2390                 users         => [\&cmd_setusers,      0],
2391         );
2392 }
2393
2394 sub do_getset {
2395         $setopt = shift;
2396         my @newargs = ();
2397         push(@newargs, shift) if @_ && $_[0] eq '--force';
2398         my $field = $_[1];
2399         (($setopt && @_ >= 3) || @_ == 2) && exists($fieldnames{$field}) or die_usage;
2400         push(@newargs, shift);
2401         shift unless ${$fieldnames{$field}}[1];
2402         push(@newargs, @_);
2403         diename(($setopt ? "set " : "get ") . $field);
2404         @ARGV = @newargs;
2405         &{${$fieldnames{$field}}[0]}(@ARGV);
2406 }
2407
2408 sub cmd_get {
2409         do_getset(0, @_);
2410 }
2411
2412 sub cmd_set {
2413         do_getset(1, @_);
2414 }
2415
2416 our %commands;
2417 BEGIN {
2418         %commands = (
2419                 list => \&cmd_list,
2420                 create => \&cmd_create,
2421                 adopt => \&cmd_adopt,
2422                 remove => \&cmd_remove,
2423                 trash => \&cmd_remove,
2424                 delete => \&cmd_remove,
2425                 prune => \&cmd_prune,
2426                 show => \&cmd_show,
2427                 verify => \&cmd_verify,
2428                 worktree => \&cmd_worktree,
2429                 worktrees => \&cmd_worktree,
2430                 urls => \&cmd_urls,
2431                 listalltags => \&cmd_listalltags,
2432                 listheads => \&cmd_listheads,
2433                 listtags => \&cmd_listtags,
2434                 listctags => \&cmd_listtags,
2435                 deltags => \&cmd_deltags,
2436                 delctags => \&cmd_deltags,
2437                 addtags => \&cmd_addtags,
2438                 addctags => \&cmd_addtags,
2439                 chpass => \&cmd_chpass,
2440                 checkpw => \&cmd_checkpw,
2441                 gc => \&cmd_gc,
2442                 update => \&cmd_update,
2443                 remirror => \&cmd_remirror,
2444                 setowner => \&cmd_setowner,
2445                 setdesc => \&cmd_setdesc,
2446                 setdescription => \&cmd_setdesc,
2447                 setreadme => \&cmd_setreadme,
2448                 sethead => \&cmd_sethead,
2449                 sethooks => \&cmd_sethooks,
2450                 sethookspath => \&cmd_sethooks,
2451                 setbool => \&cmd_setbool,
2452                 setboolean => \&cmd_setbool,
2453                 setflag => \&cmd_setbool,
2454                 setautogchack => \&cmd_setautogchack,
2455                 seturl => \&cmd_seturl,
2456                 setjsontype => \&cmd_setjsontype,
2457                 setjsonsecret => \&cmd_setjsonsecret,
2458                 setmsgs => \&cmd_setmsgs,
2459                 setusers => \&cmd_setusers,
2460                 get => \&cmd_get,
2461                 set => \&cmd_set,
2462         );
2463 }
2464 our %nopager;
2465 BEGIN { %nopager = (
2466         # 1 => pager never allowed
2467         # -1 => pager defaults to off instead of on
2468         create          => 1,
2469         adopt           => -1,
2470         remove          => -1,
2471         trash           => -1,
2472         delete          => -1,
2473         prune           => -1,
2474         deltags         => -1,
2475         delctags        => -1,
2476         addtags         => -1,
2477         addctags        => -1,
2478         chpass          => 1,
2479         checkpw         => 1,
2480         gc              => -1,
2481         update          => -1,
2482         remirror        => -1,
2483         setowner        => -1,
2484         setdesc         => -1,
2485         setdescription  => -1,
2486         setreadme       => -1,
2487         sethead         => -1,
2488         sethooks        => -1,
2489         sethookspath    => -1,
2490         setbool         => -1,
2491         setboolean      => -1,
2492         setflag         => -1,
2493         setautogchack   => -1,
2494         seturl          => -1,
2495         setjsontype     => -1,
2496         setjsonsecret   => -1,
2497         setmsgs         => -1,
2498         setusers        => -1,
2499         set             => -1,
2500         urls            => -1,
2501         verify          => 1,
2502         worktree        => 1,
2503         worktrees       => 1,
2504 )}
2505
2506 sub dohelp {
2507         my $cmd = shift;
2508         my $bn = basename($0);
2509         setup_pager_stdout($usepager);
2510         printf "%s version %s\n\n", $bn, $VERSION;
2511         if (defined($cmd) && $cmd ne '') {
2512                 $cmd =~ s/^set(?=[a-zA-Z])//i;
2513                 $cmd =~ /^worktrees?$/ and $cmd='worktree[s]';
2514                 my $cmdhelp = '';
2515                 my ($lastmt, $incmd);
2516                 foreach (split('\n', sprintf($help, $bn))) {
2517                         $lastmt || $incmd or $lastmt = /^\s*$/, next;
2518                         $incmd = 1 if $lastmt && /^\s*(?:\[?set\]?)?\Q$cmd\E\s/;
2519                         last if $incmd && /^\s*$/;
2520                         $incmd and $cmdhelp .= $_ . "\n";
2521                         $lastmt = /^\s*$/;
2522                 }
2523                 print $cmdhelp and exit 0 if $cmdhelp;
2524         }
2525         printf $help, $bn;
2526         exit 0;
2527 }
2528
2529 sub main {
2530         local *ARGV = \@_;
2531         {
2532                 shift, $quiet=1, redo if @ARGV && $ARGV[0] =~ /^(?:-q|--quiet)$/i;
2533                 shift, $usepager=1, redo if @ARGV && $ARGV[0] =~ /^(?:-p|--pager|--paginate)$/i;
2534                 shift, $usepager=0, redo if @ARGV && $ARGV[0] =~ /^(?:--no-pager|--no-paginate)$/i;
2535         }
2536         dohelp($ARGV[1]) if !@ARGV || @ARGV && $ARGV[0] =~ /^(?:-h|-?-help|help)$/i;
2537         my $command = shift;
2538         diename($command);
2539         $setopt = 1;
2540         if (!exists($commands{$command}) && exists($commands{"set".$command})) {
2541                 $setopt = 0;
2542                 $command = "set" . $command;
2543         }
2544         exists($commands{$command}) or die "Unknown command \"$command\" -- try \"help\"\n";
2545         dohelp($command) if @ARGV && ($ARGV[0] =~ /^(?:-h|-?-help)$/i ||
2546                 $ARGV[0] =~ /^help$/i && !Girocco::Project::does_exist("help",1));
2547         $nopager{$command} && $nopager{$command} > 0 and $usepager = 0;
2548         my $pgdfltoff = $nopager{$command} && $nopager{$command} < 0 ? 1 : 0;
2549         setup_pager_stdout($usepager, $pgdfltoff);
2550         &{$commands{$command}}(@ARGV);
2551 }