toolbox/projtool.pl

   1 #!/usr/bin/perl
   2
   3 # projtool.pl - command line Girocco project maintenance tool
   4 # Copyright (C) 2016,2017,2020 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.0.1'}
  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 use lib "__BASEDIR__";
  20 use Girocco::Config;
  21 use Girocco::Util;
  22 use Girocco::HashUtil;
  23 use Girocco::CLIUtil;
  24 use Girocco::Project;
  25 use Girocco::User;
  26
  27 exit(&main(@ARGV)||0);
  28
  29 our $help;
  30 BEGIN {$help = <<'HELP'}
  31 Usage: %s [--quiet] <command> <options>
  32
  33        help [<command>]
  34               show full help or just for <command> if given
  35
  36        list [--verbose] [--sort=lcname|name|owner|gid|no] [--owner] [<regexp>]
  37               list all projects (default is --sort=lcname)
  38               limit to project names matching <regex> if given
  39               match <regex> against owner instead of project name with --owner
  40
  41        create [--force] [--no-alternates] [--orphan] [<option>...] <project>
  42               create new project <project> (prompted)
  43               <option> can be:
  44                   --no-alternates skip setup of objects/info/alternates
  45                   --orphan        allow creation of subproject w/o a parent
  46                   -p              use mkdir -p during --orphan creation
  47                   --no-password   set password crypt to invalid value "unknown"
  48                   --no-owner      leave the gitweb.owner config unset
  49                   --mirror=<url>  create a mirror from <url>
  50                   --full-mirror   mirror all refs
  51                   --push[=<list>] create a push project
  52                   --desc=<string> specify project description w/o prompt
  53                   --defaults      do no interactive prompting at all
  54               Using --no-password skips the prompts for password, using
  55               --no-owner skips the prompt for owner and using --mirror=<url>
  56               or --push[=<list>] skips the prompts for mirror URL and
  57               heads-only and push users.  With --defaults if neither
  58               --mirror=<url> nor --push[=<list>] is given then --push will
  59               be implied.  Using --desc=<string> will force a specific
  60               description (including an empty string) and skip the prompt for
  61               it.  Otherwise a non-empty default description will always be
  62               supplied in lieu of an empty or omitted description.
  63
  64        adopt [--force] [--type=mirror|push] [<option>...] <project> [<users>]
  65               adopt project <project>
  66               type of project is guessed if --type=<type> omitted
  67               <users> is same as <newuserslist> for setusers command
  68               <option> can be:
  69                   --dry-run     do all the checks but don't perform adoption
  70                   --verbose     show project info dump (useful with --dry-run)
  71                   --no-users    no push users at all (<users> must be omitted)
  72                   --no-owner    leave the gitweb.owner config totally unchanged
  73                   --owner=<val> set the gitweb.owner config to <val>
  74               Both --no-owner and --owner=<val> may NOT be given, with neither
  75               take owner from preexisting gitweb.owner else use admin setting.
  76               For mirrors <users> is ignored otherwise if no <users> and no
  77               --no-users option the push users list will consist of the single
  78               user name matching the owner or empty if none or more than one.
  79               With --dry-run <project> can be an absolute path to a git dir.
  80
  81        remove [--force] [--really-delete] [--keep-forks] <project>
  82               remove project <project>
  83               do not move to _recyclebin with --really-delete (just rm -rf)
  84               remove projects with forks (by keeping forks) using --keep-forks
  85
  86        show <project>
  87               show project <project>
  88
  89        listheads <project>
  90               list all available heads for <project> and indicate current head
  91
  92        listtags [--verbose] <project>
  93               list all ctags on project <project>
  94
  95        deltags <project> [-i] <tagstodel>
  96               remove any ctags on project <project> present in <tagstodel>
  97               <tagstodel> is space or comma separated list of tags to remove
  98               with -i match against <tagstodel> without regard to letter case
  99
 100        addtags <project> <tagstoadd>
 101               add ctags to project <project>
 102               <tagstoadd> is space or comma separated list of tags to add
 103
 104        chpass [--force] <project> [random | unknown]
 105               change project <project> password (prompted)
 106               with "random" set to random password
 107               with "unknown" set password hash to invalid value "unknown"
 108
 109        checkpw <project>
 110               check project <project> password for a match (prompted)
 111
 112        gc [--force | --auto] [--redelta | --recompress] <project>
 113               run the gc.sh script on project <project>
 114               with --auto let the gc.sh script decide what to do
 115               with --force cause a full gc to take place (force_gc=1)
 116               with neither --auto nor --force do a mini or if needed a full gc
 117               (in other words just touch .needsgc and run gc.sh)
 118               with --redelta a full gc will use pack-objects --no-reuse-delta
 119               with --recompress a full gc uses pack-objects --no-reuse-object
 120               (--no-reuse-delta and --no-reuse-object are accepted as aliases)
 121               unless the global --quiet option is given show_progress=1 is used
 122
 123        update [--force] [--quiet | --summary] <project>
 124               run the update.sh script on project <project>
 125               with --force cause a fetch to always take place (force_update=1)
 126               with --quiet only show errors (show_progress is left unset)
 127               with --summary show progress and ref summary (show_progress=1)
 128               with neither --quiet nor --summary show it all (show_progress=2)
 129
 130        remirror [--force] <project>
 131               initiate a remirror of project <project>
 132
 133        [set]owner [--force] <project> <newowner>
 134               set project <project> owner to <newowner>
 135               without "set" and only 1 arg, just show current project owner
 136
 137        [set]desc [--force] <project> <newdesc>
 138               set project <project> description to <newdesc>
 139               without "set" and only 1 arg, just show current project desc
 140
 141        [set]readme [--force] <project> <newsetting>
 142               set project <project> readme to <newsetting>
 143               <newsetting> is automatic|suppressed|-|[@]filename
 144               without "set" and only 2 args, just show current readme setting
 145
 146        [set]head <project> <newhead>
 147               set project <project> HEAD symbolic ref to <newhead>
 148               without "set" and only 1 arg, just show current project HEAD
 149
 150        [set]bool [--force] <project> <flagname> <boolvalue>
 151               set project <project> boolean <flagname> to <boolvalue>
 152               <flagname> is cleanmirror|reverseorder|summaryonly|statusupdtaes
 153               without "set" and only 2 args, just show current flag value
 154
 155        [set]hooks [--force] <project> local | global | <path>
 156               set project <project> hookspath to local, global or <path>
 157               without "set" and only 1 arg, just show current hookspath
 158
 159        [set]autogchack <project> <boolvalue> | unset
 160               set project <project> autogchack to <boolvalue> or "unset" it
 161               without "set" just show current autogchack setting if enabled
 162               with "set" autogchack must be enabled in Config.pm for the
 163               type of project and maintain-auto-gc-hack.sh is always run
 164
 165        [set]url [--force] <project> <urlname> <newurlvalue>
 166               set project <project> url <urlname> to <newurlvalue>
 167               <urlname> is baseurl|homepage|notifyjson
 168               without "set" and only 2 args, just show current url value
 169
 170        [set]msgs [--force] <project> <msgsname> <eaddrlist>
 171               set project <project> msgs <msgsname> to <addrlist>
 172               <msgsname> is notifymail|notifytag
 173               <eaddrlist> is space or comma separated list of email addresses
 174               without "set" and only 2 args, just show current msgs value
 175
 176        [set]users [--force] <project> <newuserslist>
 177               set push project <project> users list to <newuserslist>
 178               <newuserslist> is space or comma separated list of user names
 179               without "set" and only 1 arg, just show current users list
 180
 181        get <project> <fieldname>
 182               show project <project> field <fieldname>
 183               <fieldname> is owner|desc|readme|head|hooks|users
 184                           or <flagname>|autogchack|<urlname>|<msgsname>
 185
 186        set [--force] <project> <fieldname> <newfieldvalue>
 187               set project <project> field <fieldname> to <newfieldvalue>
 188               <fieldname> same as for get
 189               <newfieldvalue> same as for corresponding set... command
 190 HELP
 191
 192 our $quiet;
 193 our $setopt;
 194 sub die_usage {
 195         my $sub = shift || diename;
 196         if ($sub) {
 197                 die "Invalid arguments to $sub command -- try \"help\"\n";
 198         } else {
 199                 die "Invalid arguments -- try \"help\"\n";
 200         }
 201 }
 202
 203 sub get_readme_desc {
 204         my $rm = shift;
 205         defined($rm) or $rm = '';
 206         if (length($rm)) {
 207                 my $test = $rm;
 208                 $test =~ s/<!--(?:[^-]|(?:-(?!-)))*-->//gs;
 209                 $test =~ s/\s+//s;
 210                 return $test eq '' ? "suppressed" : "length " . length($rm);
 211         } else {
 212                 return "automatic";
 213         }
 214 }
 215
 216 sub get_ctag_counts {
 217         my $project = shift;
 218         my $compact = shift;
 219         my @ctags = ();
 220         foreach ($project->get_ctag_names) {
 221                 my $val = 0;
 222                 my $ct;
 223                 if (open $ct, '<', $project->{path}."/ctags/$_") {
 224                         my $count = <$ct>;
 225                         close $ct;
 226                         defined $count or $count = '';
 227                         chomp $count;
 228                         $val = $count =~ /^[1-9]\d*$/ ? $count : 1;
 229                 }
 230                 if ($compact) {
 231                         if ($val == 1) {
 232                                 push(@ctags, $_);
 233                         } elsif ($val > 1) {
 234                                 push(@ctags, $_."(".$val.")");
 235                         }
 236                 } else {
 237                         push(@ctags, [$_, $val]) if $val;
 238                 }
 239         }
 240         @ctags;
 241 }
 242
 243 sub get_clean_project {
 244         my $project = get_project(@_);
 245         delete $project->{loaded};
 246         delete $project->{base_path};
 247         delete $project->{ccrypt};
 248         /^orig/i || !defined($project->{$_}) and delete $project->{$_} foreach keys %$project;
 249         $project->{owner} = $project->{email}; delete $project->{email};
 250         $project->{homepage} = $project->{hp}; delete $project->{hp};
 251         $project->{baseurl} = $project->{url}; delete $project->{url};
 252         if (defined($project->{path}) && $project->{path} ne "") {
 253                 my $rp = realpath($project->{path});
 254                 defined($rp) && $rp ne "" and $project->{realpath} = $rp;
 255                 if (-f "$rp/objects/info/packs") {
 256                         my $ipt = (stat _)[9];
 257                         defined($ipt) and $project->{infopackstime} =
 258                                 strftime("%Y-%m-%d %H:%M:%S %z", localtime($ipt));
 259                 }
 260         }
 261         my $owner = $project->{owner};
 262         if ($owner) {
 263                 $owner = lc($owner);
 264                 my @owner_users = map {$owner eq lc($$_[4]) ? $$_[1] : ()} get_all_users;
 265                 $project->{owner_users} = \@owner_users if @owner_users;
 266         }
 267         my $projname = $project->{name};
 268         my @forks = grep {$$_[1] =~ m,^$projname/,} get_all_projects;
 269         $project->{has_forks} = 1 if @forks;
 270         $project->{has_alternates} = 1 if $project->has_alternates;
 271         my @bundles = $project->bundles;
 272         for (my $i = 0; $i < @bundles; ++$i) {
 273                 my $secs = $bundles[$i]->[0];
 274                 $bundles[$i]->[0] = strftime("%Y-%m-%d %H:%M:%S %z", localtime($secs));
 275                 my $sz = $bundles[$i]->[2];
 276                 1 while $sz =~ s/(?<=\d)(\d{3})(?:,|$)/,$1/g;
 277                 $bundles[$i]->[2] = $sz;
 278         }
 279         delete $project->{bundles};
 280         $project->{bundles} = \@bundles if @bundles;
 281         $project->{mirror} = 0 unless $project->{mirror};
 282         $project->{is_empty} = 1 if $project->is_empty;
 283         delete $project->{showpush} unless $project->{showpush};
 284         delete $project->{users} if $project->{mirror};
 285         delete $project->{baseurl} unless $project->{mirror};
 286         delete $project->{banged} unless $project->{mirror};
 287         delete $project->{lastrefresh} unless $project->{mirror};
 288         delete $project->{cleanmirror} unless $project->{mirror};
 289         delete $project->{statusupdates} unless $project->{mirror};
 290         delete $project->{lastparentgc} unless $projname =~ m,/,;
 291         unless ($project->{banged}) {
 292                 delete $project->{bangcount};
 293                 delete $project->{bangfirstfail};
 294                 delete $project->{bangmessagesent};
 295         }
 296         my $projhook = $project->_has_notifyhook;
 297         if (defined($projhook) && $projhook ne "") {
 298                 $project->{notifyhook} = $projhook;
 299         } else {
 300                 delete $project->{notifyhook};
 301         }
 302         $project->{README} = get_readme_desc($project->{README}) if exists($project->{README});
 303         my @tags = get_ctag_counts($project, 1);
 304         $project->{tags} = \@tags if @tags;
 305         my $projconfig = read_config_file_hash($project->{path}."/config");
 306         if (defined($projconfig) && defined($projconfig->{"core.hookspath"})) {
 307                 my $ahp = $projconfig->{"core.hookspath"};
 308                 my $rahp = realpath($ahp);
 309                 my $lhp = $project->{path}."/hooks";
 310                 my $rlhp = realpath($lhp);
 311                 my $ghp = $Girocco::Config::reporoot."/_global/hooks";
 312                 my $rghp = realpath($ghp);
 313                 $project->{has_local_hooks} = 1 if
 314                         defined($rahp) && defined($rlhp) && $rahp eq $rlhp;
 315                 $project->{has_global_hooks} = 1 if
 316                         defined($rahp) && defined($rghp) && $rahp eq $rghp;
 317                 $project->{hookspath} = $ahp unless $ahp eq $lhp || $ahp eq $ghp;
 318         }
 319         $project;
 320 }
 321
 322 sub clean_addrlist {
 323         my %seen = ();
 324         my @newlist = ();
 325         foreach (split(/[,\s]+/, $_[0])) {
 326                 next unless $_;
 327                 $seen{lc($_)} = 1, push(@newlist, $_) unless $seen{lc($_)};
 328         }
 329         return join(($_[1]||","), @newlist);
 330 }
 331
 332 sub valid_addrlist {
 333         my $cleaned = clean_addrlist(join(" ", @_));
 334         return 1 if $cleaned eq "";
 335         valid_email_multi($cleaned) && length($cleaned) <= 512;
 336 }
 337
 338 sub validate_users {
 339         my ($userlist, $force, $nodie, $quiet) = @_;
 340         my @newusers = ();
 341         my $badlist = 0;
 342         my %seenuser = ();
 343         my $mobok = $Girocco::Config::mob && $Girocco::Config::mob eq "mob";
 344         my %users = map({($$_[1] => $_)} get_all_users);
 345         foreach (split(/[\s,]+/, $userlist)) {
 346                 if (exists($users{$_}) || $_ eq "everyone" || ($mobok && $_ eq "mob")) {
 347                         $seenuser{$_}=1, push(@newusers, $_) unless $seenuser{$_};
 348                         next;
 349                 }
 350                 if (Girocco::User::does_exist($_, 1)) {
 351                         if ($force) {
 352                                 $seenuser{$_}=1, push(@newusers, $_) unless $seenuser{$_};
 353                         } else {
 354                                 $badlist = 1;
 355                                 warn "refusing to allow questionable user \"$_\" without --force\n" unless $nodie && $quiet;
 356                         }
 357                         next;
 358                 }
 359                 $badlist = 1;
 360                 warn "invalid user: \"$_\"\n" unless $nodie && $quiet
 361         }
 362         die if $badlist && !$nodie;
 363         return @newusers;
 364 }
 365
 366 sub is_default_desc {
 367         # "Unnamed repository; edit this file 'description' to name the repository."
 368         # "Unnamed repository; edit this file to name it for gitweb."
 369         local $_ = shift;
 370         return 0 unless defined($_);
 371         /Unnamed\s+repository;/i && /\s+edit\s+this\s+file\s+/i && /\s+to\s+name\s+/i;
 372 }
 373
 374 sub valid_desc {
 375         my $test = shift;
 376         chomp $test;
 377         return 0 if $test =~ /[\r\n]/;
 378         $test =~ s/\s\s+/ /g;
 379         $test =~ s/^\s+//;
 380         $test =~ s/\s+$//;
 381         return $test ne '';
 382 }
 383
 384 sub clean_desc {
 385         my $desc = shift;
 386         defined($desc) or $desc = '';
 387         chomp $desc;
 388         $desc = to_utf8($desc, 1);
 389         $desc =~ s/\s\s+/ /g;
 390         $desc =~ s/^\s+//;
 391         $desc =~ s/\s+$//;
 392         return $desc;
 393 }
 394
 395 sub parse_options {
 396         Girocco::CLIUtil::_parse_options(
 397                 sub {
 398                         warn((($_[0]eq'?')?"unrecognized":"missing argument for")." option \"$_[1]\"\n")
 399                                 unless $quiet;
 400                         die_usage;
 401                 }, @_);
 402 }
 403
 404 sub cmd_list {
 405         my %sortsub = (
 406                 lcname => sub {lc($$a[1]) cmp lc($$b[1])},
 407                 name => sub {$$a[1] cmp $$b[1]},
 408                 gid => sub {$$a[3] <=> $$b[3]},
 409                 owner => sub {lc($$a[4]) cmp lc($$b[4]) || lc($$a[1]) cmp lc($$b[1])},
 410                 no => sub {$$a[0] <=> $$b[0]},
 411         );
 412         my $sortopt = 'lcname';
 413         my ($verbose, $owner);
 414         parse_options(":sort" => \$sortopt, verbose => \$verbose, owner => \$owner);
 415         my $regex;
 416         if (@ARGV) {
 417                 my $val = shift @ARGV;
 418                 $regex = qr($val) or die "bad regex \"$val\"\n";
 419         }
 420         !@ARGV && exists($sortsub{$sortopt}) or die_usage;
 421         my $sortsub = $sortsub{$sortopt};
 422         my $grepsub = defined($regex) ? ($owner ? sub {$$_[4] =~ /$regex/} : sub {$$_[1] =~ /$regex/}) : sub {1};
 423         my @projects = sort($sortsub grep {&$grepsub} get_all_projects);
 424         if ($verbose) {
 425                 print map(sprintf("%s\n", join(":", (@$_)[1..5])), @projects);
 426         } else {
 427                 print map(sprintf("%s: %s\n", $$_[1], $$_[5] =~ /^:/ ? "<mirror>" : $$_[5]), @projects);
 428         }
 429         return 0;
 430 }
 431
 432 sub cmd_create {
 433         my ($force, $noalternates, $orphanok, $optp, $nopasswd, $noowner, $defaults, $ispush, $pushusers,
 434                 $ismirror, $desc, $fullmirror);
 435         parse_options(
 436                 force => \$force, "no-alternates" => \$noalternates, orphan => \$orphanok, p => \$optp,
 437                 "no-password" => \$nopasswd, "no-owner" => \$noowner, defaults => \$defaults,
 438                 "push" => \$ispush, ":push" => \$pushusers, ":mirror" => \$ismirror, ":desc" => \$desc,
 439                 ":description" => \$desc, "full-mirror" => \$fullmirror);
 440         @ARGV == 1 or die_usage;
 441         !defined($pushusers) || defined($ispush) or $ispush = 1;
 442         defined($ismirror) && $ismirror =~ /^\s*$/ and die "--mirror url must not be empty\n";
 443         die "--mirror and --push are mutually exclusive options\n" if $ismirror && $ispush;
 444         die "--full-mirror requires use of --mirror=<url> option\n" if $fullmirror && !$ismirror;
 445         !$defaults || defined($ispush) || defined($ismirror) or $ispush = 1;
 446         !$defaults || defined($nopasswd) or $nopasswd = 1;
 447         !$defaults || defined($noowner) or $noowner = 1;
 448         !defined($ispush) || defined($pushusers) or $pushusers = "";
 449         my $projname = $ARGV[0];
 450         $projname =~ s/\.git$//i;
 451         Girocco::Project::does_exist($projname, 1) and die "Project already exists: \"$projname\"\n";
 452         if (!Girocco::Project::valid_name($projname, $orphanok, $optp)) {
 453                 warn "Refusing to create orphan project without --orphan\n"
 454                         if !$quiet && !$orphanok && Girocco::Project::valid_name($projname, 1, 1);
 455                 warn "Required orphan parent directory does not exist (use -p): ",
 456                         $Girocco::Config::reporoot.'/'.Girocco::Project::get_forkee_name($projname), "\n"
 457                         if !$quiet && $orphanok && Girocco::Project::valid_name($projname, 1, 1);
 458                 die "Invalid project name: \"$projname\"\n";
 459         }
 460         my ($forkee, $project) = ($projname =~ m#^(.*/)?([^/]+)$#);
 461         my $newtype = $forkee ? 'fork' : 'project';
 462         if (length($project) > 64) {
 463                 die "The $newtype name is longer than 64 characters.  Do you really need that much?\n"
 464                         unless $force;
 465                 warn "Allowing $newtype name longer than 64 characters with --force\n" unless $quiet;
 466         }
 467         unless ($Girocco::Config::push || $Girocco::Config::mirror) {
 468                 die "Project creation disabled (no mirrors or push projects allowed)\n" unless $force;
 469                 warn "Continuing with --force even though both push and mirror projects are disabled\n" unless $quiet;
 470         }
 471         print "Enter settings for new project \"$projname\"\n" unless $defaults;
 472         my %settings = ();
 473         $settings{noalternates} = $noalternates;
 474         if ($nopasswd) {
 475                 $settings{crypt} = "unknown";
 476         } else {
 477                 my $np1 = prompt_noecho_nl_or_die("Admin password for project $projname (echo is off)");
 478                 $np1 ne "" or die "empty passwords are not permitted (brokenness will ensue)\n";
 479                 my $np2 = prompt_noecho_nl_or_die("Retype admin password for project $projname");
 480                 $np1 eq $np2 or die "Our high-paid security consultants have determined that\n" .
 481                         "the admin passwords you have entered do not match each other.\n";
 482                 $settings{crypt} = scrypt_sha1($np1);
 483         }
 484         my $owner = "";
 485         unless ($noowner) {
 486                 $owner = prompt_or_die("Owner/email name for project $projname");
 487                 unless (valid_email($owner)) {
 488                         unless ($force) {
 489                                 warn "Your email sure looks weird...?\n";
 490                                 redo;
 491                         }
 492                         warn "Allowing invalid email with --force\n" unless $quiet;
 493                 }
 494                 if (length($owner) > 96) {
 495                         unless ($force) {
 496                                 warn "Your email is longer than 96 characters.  Do you really need that much?\n";
 497                                 redo;
 498                         }
 499                         warn "Allowing email longer than 96 characters with --force\n" unless $quiet;
 500                 }
 501         }
 502         $settings{email} = $owner;
 503         my $baseurl = "";
 504         my $checkmirror = sub {
 505                 my $checkurl = shift;
 506                 unless (valid_repo_url($checkurl)) {
 507                         unless ($force) {
 508                                 warn "Invalid mirror URL: \"$checkurl\"\n";
 509                                 return undef;
 510                         }
 511                         warn "Allowing invalid mirror URL with --force\n" unless $quiet;
 512                 }
 513                 if ($Girocco::Config::restrict_mirror_hosts) {
 514                         my $mh = extract_url_hostname($checkurl);
 515                         unless (is_dns_hostname($mh)) {
 516                                 unless ($force) {
 517                                         warn "Invalid non-DNS mirror URL: \"$checkurl\"\n";
 518                                         return undef;
 519                                 }
 520                                 warn "Allowing non-DNS mirror URL with --force\n" unless $quiet;
 521                         }
 522                         if (is_our_hostname($mh)) {
 523                                 unless ($force) {
 524                                         warn "Invalid same-host mirror URL: \"$checkurl\"\n";
 525                                         return undef;
 526                                 }
 527                                 warn "Allowing same-host mirror URL with --force\n" unless $quiet;
 528                         }
 529                 }
 530                 return $checkurl;
 531         };
 532         if ($ispush || $ismirror) {
 533                 !$ispush || $force || $Girocco::Config::push or
 534                         die "Push projects are disabled, create a mirror (or use --force)\n";
 535                 !$ismirror || $force || $Girocco::Config::mirror or
 536                         die "Mirror projects are disabled, create a push project (or use --force)\n";
 537                 if ($ismirror) {
 538                         &$checkmirror($ismirror) or die "Invalid --mirror URL\n";
 539                         $baseurl = $ismirror;
 540                         $settings{url} = $baseurl;
 541                         $settings{cleanmirror} = $fullmirror ? 0 : 1;
 542                 } else {
 543                         my @newusers = ();
 544                         if ($pushusers !~ /^[\s,]*$/) {
 545                                 eval {@newusers = validate_users($pushusers, $force); 1;} or
 546                                         die "Invalid --push user list\n";
 547                         }
 548                         $settings{users} = \@newusers;
 549                 }
 550         } elsif ($force || $Girocco::Config::mirror) {{
 551                 if ($force || $Girocco::Config::push) {
 552                         $baseurl = prompt_or_die("URL to mirror from (leave blank for push project)", "");
 553                 } else {{
 554                         $baseurl = prompt_or_die("URL to mirror from");
 555                         unless ($baseurl ne "") {
 556                                 warn "Push projects are disabled, you must enter a mirror URL (or use --force)\n";
 557                                 redo;
 558                         }
 559                 }}
 560                 if ($baseurl ne "") {
 561                         &$checkmirror($baseurl) or redo;
 562                         $settings{url} = $baseurl;
 563                         $settings{cleanmirror} =
 564                                 ynprompt_or_die("Mirror only heads, tags and notes (Y/n)", "Yes");
 565                 }
 566         }}
 567         my $mirror = ($baseurl eq "") ? 0 : 1;
 568         my $checkdesc = sub {
 569                 my $d = shift;
 570                 if (length($d) > 1024) {
 571                         unless ($force) {
 572                                 warn "Short description length greater than 1024 characters!\n";
 573                                 return undef;
 574                         }
 575                         warn "Allowing short description length greater than 1024 characters\n" unless $quiet;
 576                 }
 577                 return $d;
 578         };
 579         if (defined($desc)) {
 580                 $desc =~ s/^\s+//; $desc =~ s/\s+$//;
 581                 $desc eq "" || &$checkdesc($desc) or
 582                         die "Invalid --desc description\n";
 583         } elsif (!$defaults) {
 584                 $desc = prompt_or_die("Short description", "");
 585                 $desc =~ s/^\s+//; $desc =~ s/\s+$//;
 586                 $desc eq "" || &$checkdesc($desc) or redo;
 587                 $desc = undef if $desc eq "";
 588         }
 589         defined($desc) or $desc = $mirror ? "Mirror of $baseurl" : "Push project $projname";
 590         $settings{desc} = $desc;
 591         my $homepage = "";
 592         if (!$defaults) {
 593                 $homepage = prompt_or_die("Home page URL", "");
 594                 if ($homepage ne "" && !valid_web_url($homepage)) {
 595                         unless ($force) {
 596                                 warn "Invalid home page URL: \$homepage\"\n";
 597                                 redo;
 598                         }
 599                         warn "Allowing invalid home page URL with --force\n" unless $quiet;
 600                 }
 601         }
 602         $settings{hp} = $homepage;
 603         my $jsonurl = "";
 604         if (!$defaults) {
 605                 $jsonurl = prompt_or_die("JSON notify POST URL", "");
 606                 if ($jsonurl ne "" && !valid_web_url($jsonurl)) {
 607                         unless ($force) {
 608                                 warn "Invalid JSON notify POST URL: \$jsonurl\"\n";
 609                                 redo;
 610                         }
 611                         warn "Allowing invalid JSON notify POST URL with --force\n" unless $quiet;
 612                 }
 613         }
 614         $settings{notifyjson} = $jsonurl;
 615         my $commitaddrs = "";
 616         if (!$defaults) {
 617                 $commitaddrs = clean_addrlist(prompt_or_die("Commit notify email addr(s)", ""));
 618                 if ($commitaddrs ne "" && !valid_addrlist($commitaddrs)) {
 619                         unless ($force) {
 620                                 warn"invalid commit notify email address list (use --force to accept): \"$commitaddrs\"\n";
 621                                 redo;
 622                         }
 623                         warn "using invalid commit notify email address list with --force\n" unless $quiet;
 624                 }
 625         }
 626         $settings{notifymail} = $commitaddrs;
 627         $settings{reverseorder} = 1;
 628         $settings{reverseorder} = ynprompt_or_die("Oldest-to-newest commit order in emails", "Yes")
 629                 if !$defaults && $commitaddrs ne "";
 630         $settings{summaryonly} = ynprompt_or_die("Summary only (no diff) in emails", "No")
 631                 if !$defaults && $commitaddrs ne "";
 632         my $tagaddrs = "";
 633         if (!$defaults) {
 634                 $tagaddrs = clean_addrlist(prompt_or_die("Tag notify email addr(s)", ""));
 635                 if ($tagaddrs ne "" && !valid_addrlist($tagaddrs)) {
 636                         unless ($force) {
 637                                 warn"invalid tag notify email address list (use --force to accept): \"$tagaddrs\"\n";
 638                                 redo;
 639                         }
 640                         warn "using invalid tag notify email address list with --force\n" unless $quiet;
 641                 }
 642         }
 643         $settings{notifytag} = $tagaddrs;
 644         if (!$mirror && !$ispush) {
 645                 my @newusers = ();
 646                 {
 647                         my $userlist = prompt_or_die("Push users", join(",", @newusers));
 648                         eval {@newusers = validate_users($userlist, $force); 1;} or redo;
 649                 }
 650                 $settings{users} = \@newusers;
 651         }
 652         my $newproj = Girocco::Project->ghost($projname, $mirror, $orphanok, $optp)
 653                 or die "Girocco::Project->ghost call failed\n";
 654         my ($k, $v);
 655         $newproj->{$k} = $v while ($k, $v) = each(%settings);
 656         my $killowner = sub {
 657                 system($Girocco::Config::git_bin, '--git-dir='.$newproj->{path},
 658                         'config', '--unset', "gitweb.owner");
 659         };
 660         if ($mirror) {
 661                 $newproj->premirror or die "Girocco::Project->premirror failed\n";
 662                 !$noowner or &$killowner;
 663                 $newproj->clone or die "Girocco::Project->clone failed\n";
 664                 warn "Project $projname created and cloning successfully initiated.\n"
 665                         unless $quiet;
 666         } else {
 667                 $newproj->conjure or die "Girocco::Project->conjure failed\n";
 668                 !$noowner or &$killowner;
 669                 warn "New push project fork is empty due to use of --no-alternates\n"
 670                         if !$quiet && $projname =~ m,/, && $noalternates;
 671                 warn "Project $projname successfully created.\n" unless $quiet;
 672         }
 673         return 0;
 674 }
 675
 676 sub git_config {
 677         my $gd = shift;
 678         system($Girocco::Config::git_bin, "--git-dir=$gd", 'config', @_) == 0
 679                 or die "\"git --git-dir='$gd' config ".join(" ", @_)."\" failed.\n";
 680 }
 681
 682 sub cmd_adopt {
 683         my ($force, $type, $nousers, $dryrun, $noowner, $owner, $users, $verbose);
 684         parse_options(force => \$force, ":type" => \$type, "no-users" => \$nousers, "dry-run" => \$dryrun,
 685                 "no-owner" => \$noowner,":owner" => \$owner, quiet => \$quiet, q =>\$quiet, verbose => \$verbose);
 686         @ARGV or die "Please give project name on command line.\n";
 687         my $projname = shift @ARGV;
 688         (!$noowner || !defined($owner)) && (!$nousers || !@ARGV) or die_usage;
 689         !defined($type) || $type eq "mirror" || $type eq "push" or die_usage;
 690         defined($type) or $type = "";
 691         my $projdir;
 692         if ($dryrun && $projname =~ m,^/[^.\s/\\:], && is_git_dir(realpath($projname))) {
 693                 $projdir = realpath($projname);
 694                 $projname = $projdir;
 695                 $projname =~ s/\.git$//i;
 696                 $projname =~ s,/+$,,;
 697                 $projname =~ s,^.*/,,;
 698                 $projname ne "" or $projname = $projdir;
 699         } else {
 700                 $projname =~ s/\.git$//i;
 701                 $projname ne "" or die "Invalid project name \"\".\n";
 702                 unless (Girocco::Project::does_exist($projname, 1)) {
 703                         Girocco::Project::valid_name($projname, 1, 1)
 704                                 or die "Invalid project name \"$projname\".\n";
 705                         die "No such project to adopt: $projname\n";
 706                 }
 707                 defined(Girocco::Project->load($projname))
 708                         and die "Project already known (no need to adopt): $projname\n";
 709                 $projdir = $Girocco::Config::reporoot . "/" . $projname . ".git";
 710                 is_git_dir($projdir) or die "Not a git directory: \"$projdir\"\n";
 711         }
 712         my $config = read_config_file($projdir . "/config");
 713         my %config = ();
 714         %config = map {($$_[0], defined($$_[1])?$$_[1]:"true")} @$config if defined($config);
 715         git_bool($config{"core.bare"}) or die "Not a bare git repository: \"$projdir\"\n";
 716         defined(read_HEAD_symref($projdir)) or die "Project with non-symbolic HEAD ref: \"$projdir\"\n";
 717         @ARGV and $users = [validate_users(join(" ", @ARGV), $force, 1, $quiet)];
 718         my $desc = "";
 719         if (-e "$projdir/description") {
 720                 open my $fd, '<', "$projdir/description" or die "Cannot open \"$projdir/description\": $!\n";
 721                 {
 722                         local $/;
 723                         $desc = <$fd>;
 724                 }
 725                 close $fd;
 726                 defined $desc or $desc = "";
 727                 chomp $desc;
 728                 $desc = to_utf8($desc, 1);
 729                 is_default_desc($desc) and $desc = "";
 730                 if ($desc ne "" && !valid_desc($desc)) {
 731                         die "invalid 'description' file contents (use --force to accept): \"$desc\"\n"
 732                                 unless $force;
 733                         warn "using invalid 'description' file contents  with --force\n" unless $quiet;
 734                 }
 735                 $desc = clean_desc($desc);
 736                 if (length($desc) > 1024) {
 737                         die "description longer than 1024 chars (use --force to accept): \"$desc\"\n"
 738                                 unless $force;
 739                         warn "using longer than 1024 char description with --force\n" unless $quiet;
 740                 }
 741         }
 742         my $readme = "";
 743         if (-e "$projdir/README.html") {
 744                 open my $fd, '<', "$projdir/README.html" or die "Cannot open \"$projdir/README.html\": $!\n";
 745                 {
 746                         local $/;
 747                         $readme = <$fd>;
 748                 }
 749                 close $fd;
 750                 defined $readme or $readme = "";
 751                 $readme = to_utf8($readme, 1);
 752                 $readme =~ s/\r\n?/\n/gs;
 753                 $readme =~ s/^\s+//s;
 754                 $readme =~ s/\s+$//s;
 755                 $readme eq "" or $readme .= "\n";
 756                 if (length($readme) > 8192) {
 757                         die "readme greater than 8192 chars is too long (use --force to override)\n"
 758                                 unless $force;
 759                         warn "using readme greater than 8192 chars with --force\n" unless $quiet;
 760                 }
 761                 my $rd = get_readme_desc($readme);
 762                 if ($rd ne "automatic" && $rd ne "suppressed") {
 763                         my $xmllint = qx(sh -c 'command -v xmllint'); chomp $xmllint;
 764                         if (-f $xmllint && -x $xmllint) {
 765                                 my $dummy = {README => $readme};
 766                                 my ($cnt, $err) = Girocco::Project::_lint_readme($dummy, 0);
 767                                 if ($cnt) {
 768                                         my $msg = "xmllint: $cnt error";
 769                                         $msg .= "s" unless $cnt == 1;
 770                                         print STDERR "$msg\n", "-" x length($msg), "\n", $err
 771                                                 unless $force && $quiet;
 772                                         exit(255) unless $force;
 773                                         warn "$projname: using invalid raw HTML with --force\n" unless $quiet;
 774                                 }
 775                         } else {
 776                                 die "xmllint not available, refusing to use raw HTML without --force\n"
 777                                         unless $force;
 778                                 warn "xmllint not available using unchecked raw HTML with --force\n" unless $quiet;
 779                         }
 780                 }
 781         }
 782         # Inspect any remotes now
 783         # Yes, Virginia, remote urls can be multi-valued
 784         my %remotes = ();
 785         foreach (@$config) {
 786                 my ($k,$v) = @$_;
 787                 next unless $k =~ /^remote\.([^\/].*?)\.([^.]+)$/; # remote name cannot start with "/"
 788                 my ($name, $subkey) = ($1, $2);
 789                 $remotes{$name}->{skip} = git_bool($v,1), next if $subkey eq "skipdefaultupdate" || $subkey eq "skipfetchall";
 790                 $remotes{$name}->{mirror} = git_bool($v,1), next if $subkey eq "mirror"; # we might want this
 791                 $remotes{$name}->{vcs} = $v, next if defined($v) && $v !~ /^\s*$/ && $subkey eq "vcs";
 792                 push(@{$remotes{$name}->{$subkey}}, $v), next if defined($v) && $v !~ /^\s*$/ &&
 793                         ($subkey eq "url" || $subkey eq "fetch" || $subkey eq "push" || $subkey eq "pushurl");
 794         }
 795         # remotes.default is the default remote group to fetch for "git remote update" otherwise --all
 796         # the remote names in a group are separated by runs of [ \t\n] characters
 797         # remote names "", ".", ".." and any name starting with "/" are invalid
 798         # a remote with no url or vcs setting is not considered valid
 799         my @check = ();
 800         my $usingall = 0;
 801         if (exists($config{"remotes.default"})) {
 802                 foreach (split(/[ \t\n]+/, $config{"remotes.default"})) {
 803                         next unless exists($remotes{$_});
 804                         my $rmt = $remotes{$_};
 805                         next if !exists($rmt->{url}) && !$rmt->{vcs};
 806                         push(@check, $_);
 807                 }
 808         } else {
 809                 $usingall = 1;
 810                 my %seenrmt = ();
 811                 foreach (@$config) {
 812                         my ($k,$v) = @$_;
 813                         next unless $k =~ /^remote\.([^\/].*?)\.[^.]+$/;
 814                         next if $seenrmt{$1};
 815                         $seenrmt{$1} = 1;
 816                         next unless exists($remotes{$1});
 817                         my $rmt = $remotes{$1};
 818                         next if $rmt->{skip} || (!exists($rmt->{url}) && !$rmt->{vcs});
 819                         push(@check, $1);
 820                 }
 821         }
 822         my @needskip = (); # remotes that need skipDefaultUpdate set to true
 823         my $foundvcs = 0;
 824         my $foundfetch = 0;
 825         my $foundfetchwithmirror = 0;
 826         foreach (@check) {
 827                 my $rmt = $remotes{$_};
 828                 push(@needskip, $_) if $usingall && !exists($rmt->{fetch});
 829                 next unless exists($rmt->{fetch});
 830                 ++$foundfetch;
 831                 ++$foundfetchwithmirror if $rmt->{mirror};
 832                 ++$foundvcs if $rmt->{vcs} || (exists($rmt->{url}) && $rmt->{url}->[0] =~ /^[a-zA-Z0-9][a-zA-Z0-9+.-]*::/);
 833         }
 834         # if we have $foundvcs then we need to explicitly set fetch.prune to false
 835         # if we have $foundfetch > 1 then we need to explicitly set fetch.prune to false
 836         my $neednoprune = !exists($config{"fetch.prune"}) && ($foundvcs || $foundfetch > 1);
 837         my $baseurl = "";
 838         my $needfakeorigin = 0; # if true we need to set remote.origin.skipDefaultUpdate = true
 839         # if remote "origin" exists we always pick up its first url or use ""
 840         if (exists($remotes{origin})) {
 841                 my $rmt = $remotes{origin};
 842                 $baseurl = exists($rmt->{url}) ? $rmt->{url}->[0] : "";
 843                 $needfakeorigin = !exists($rmt->{url}) && !$rmt->{vcs} && !$rmt->{skip};
 844         } else {
 845                 $needfakeorigin = 1;
 846                 # get the first url of the @check remotes
 847                 foreach (@check) {
 848                         my $rmt = $remotes{$_};
 849                         next unless exists($rmt->{url});
 850                         next unless defined($rmt->{url}->[0]) && $rmt->{url}->[0] ne "";
 851                         $baseurl = $rmt->{url}->[0];
 852                         last;
 853                 }
 854         }
 855         my $makemirror = $type eq "mirror" || ($type eq "" && $foundfetch);
 856
 857         # If we have $foundfetch we want to make a mirror but complain if
 858         # we $foundfetchwithmirror as well unless we have --type=mirror.
 859         # Warn if we have --type=push and $foundfetch and !$foundfetchwithmirror.
 860         # Warn if we need to set fetch.prune=false when making a mirror
 861         # Warn if we need to create remote.origin.skipDefaultUpdate when making a mirror
 862         # Complain if @needskip AND !$usingall (warn with --force but don't set skip)
 863         # Warn if $usingall and any @needskip (and set them) if making a mirror
 864         # Warn if making a mirror and $baseurl eq ""
 865         # Warn if we have --type=mirror and !$foundfetch
 866
 867         if ($makemirror) {
 868                 warn "No base URL to mirror from for adopted \"$projname\"\n" unless $quiet || $baseurl ne "";
 869                 warn "Adopting mirror \"$projname\" without any fetch remotes\n" unless $quiet || $foundfetch;
 870                 if ($foundfetchwithmirror) {
 871                         warn "Refusing to adopt mirror \"$projname\" with active remote.<name>.mirror=true remote(s)\n".
 872                             "(Use --type=mirror to override)\n"
 873                                 unless $type eq "mirror";
 874                         exit(255) unless $type eq "mirror" || $dryrun;
 875                         warn "Adopting mirror \"$projname\" with active remote.<name>.mirror=true remotes\n"
 876                                 unless $quiet || $type ne "mirror";
 877                 }
 878                 warn "Setting explicit fetch.prune=false for adoption of mirror \"$projname\"\n"
 879                         if !$quiet && $neednoprune;
 880                 warn "Setting remote.origin.skipDefaultUpdate=true for adoption of mirror \"$projname\"\n"
 881                         if !$quiet && $needfakeorigin;
 882                 if (!$usingall && @needskip) {
 883                         warn "Refusing to adopt mirror empty fetch remote(s) (override with --force)\n"
 884                                 unless $force;
 885                         exit(255) unless $force || $dryrun;
 886                         warn "Adopting mirror with empty fetch remote(s) with --force\n"
 887                                 unless $quiet || !$force;
 888                 }
 889                 warn "Will set skipDefaultUpdate=true on non-fetch remote(s)\n" if !$quiet && $usingall && @needskip;
 890                 warn "Adopting mirror with base URL \"$baseurl\"\n" unless $quiet || $baseurl eq "";
 891         } else {
 892                 warn "Adopting push \"$projname\" but active non-mirror remotes are present\n"
 893                         if !$quiet && $foundfetch && !$foundfetchwithmirror;
 894         }
 895
 896         if (!$noowner && !defined($owner)) {
 897                 # Select the owner
 898                 $owner = $config{"gitweb.owner"};
 899                 if (!defined($owner) || $owner eq "") {
 900                         $owner = $Girocco::Config::admin;
 901                         warn "Using owner \"$owner\" for adopted project\n" unless $quiet;
 902                 }
 903         }
 904         if (!$nousers && !$makemirror && !defined($users)) {
 905                 # select user list for push project
 906                 my $findowner = $owner;
 907                 defined($findowner) or $findowner = $config{"gitweb.owner"};
 908                 $findowner = lc($findowner) if defined($findowner);
 909                 my @owner_users = ();
 910                 @owner_users = map {$findowner eq lc($$_[4]) ? $$_[1] : ()} get_all_users
 911                         if defined($findowner) && $findowner ne "";
 912                 if (@owner_users <= 1) {
 913                         $users = \@owner_users;
 914                         warn "No users found that match owner \"$findowner\"\n" unless @owner_users || $quiet;
 915                 } else {
 916                         $users = [];
 917                         warn "Found ".scalar(@owner_users)." users for owner \"$findowner\" (" .
 918                                 join(" ", @owner_users) . ") not setting any\n" unless $quiet;
 919                 }
 920         }
 921         defined($users) or $users = [];
 922
 923         # Warn if we preserve an existing receive.denyNonFastForwards or receive.denyDeleteCurrent setting
 924         # Complain if core.logallrefupdates or logs subdir exists and contains any files (allow with --force
 925         # and warn about preserving the setting)
 926
 927         warn "Preserving existing receive.denyNonFastForwards=true\n"
 928                 if !$quiet && git_bool($config{"receive.denynonfastforwards"});
 929         warn "Preserving existing receive.denyDeleteCurrent=$config{'receive.denydeletecurrent'}\n"
 930                 if !$quiet && exists($config{"receive.denydeletecurrent"}) &&
 931                     $config{"receive.denydeletecurrent"} ne "warn";
 932
 933         my $reflogfiles = Girocco::Project::_contains_files("$projdir/logs");
 934         my $reflogactive = git_bool($config{"core.logallrefupdates"});
 935         if ($reflogactive || $reflogfiles) {
 936                 warn "Refusing to adopt \"$projname\" with active ref logs without --force\n" if $reflogfiles && !$force;
 937                 warn "Refusing to adopt \"$projname\" with core.logAllRefUpdates=true without --force\n" if $reflogactive && !$force;
 938                 exit(255) unless $force || $dryrun;
 939                 warn "Adopting \"$projname\" with active ref logs with --force\n" unless $quiet || ($reflogfiles && !$force);
 940                 warn "Adopting \"$projname\" with core.logAllRefUpdates=true with --force\n" unless $quiet || ($reflogactive && !$force);
 941         }
 942
 943         return 0 if $dryrun && !$verbose;
 944
 945         my $newproj = eval {Girocco::Project->ghost($projname, $makemirror, 1, $dryrun)};
 946         defined($newproj) or die "Girocco::Project::ghost failed: $@\n";
 947         $newproj->{desc} = $desc;
 948         $newproj->{README} = $readme;
 949         $newproj->{url} = $baseurl if $makemirror || exists($config{"gitweb.baseurl"});
 950         $newproj->{email} = $owner if defined($owner);
 951         $newproj->{users} = $users;
 952         $newproj->{crypt} = "unknown";
 953         $newproj->{reverseorder} = 1 unless exists($config{"hooks.reverseorder"});
 954         $newproj->{summaryonly} = 1 unless exists($config{"hooks.summaryonly"});
 955         my $dummy = bless {}, "Girocco::Project";
 956         $dummy->{path} = "$projdir";
 957         $dummy->{configfilehash} = \%config;
 958         $dummy->_properties_load;
 959         delete $dummy->{origurl};
 960         foreach my $k (keys(%$dummy)) {
 961                 $newproj->{$k} = $dummy->{$k}
 962                         if exists($dummy->{$k}) && !exists($newproj->{$k});
 963         }
 964
 965         if ($verbose) {
 966                 use Data::Dumper;
 967                 my %info = %$newproj;
 968                 $info{README} = get_readme_desc($info{README}) if exists($info{README});
 969                 my $d = Data::Dumper->new([\%info], ['*'.$newproj->{name}]);
 970                 $d->Sortkeys(sub {[sort({lc($a) cmp lc($b)} keys %{$_[0]})]});
 971                 print $d->Dump([\%info], ['*'.$newproj->{name}]);
 972         }
 973         return 0 if $dryrun;
 974
 975         # Make any changes as needed for @needskip, $neednoprune and $needfakeorigin
 976         if ($makemirror) {
 977                 git_config($projdir, "fetch.prune", "false") if $neednoprune;
 978                 git_config($projdir, "remote.origin.skipDefaultUpdate", "true") if $needfakeorigin;
 979                 if ($usingall && @needskip) {
 980                         git_config($projdir, "remote.$_.skipDefaultUpdate", "true") foreach @needskip;
 981                 }
 982         }
 983
 984         # Perform the actual adoption
 985         $newproj->adopt or die "Girocco::Project::adopt failed\n";
 986
 987         # Perhaps restore core.logAllRefUpdates, receive.denyNonFastForwards and receive.denyDeleteCurrent
 988         git_config($projdir, "receive.denyNonFastForwards", "true")
 989                 if git_bool($config{"receive.denynonfastforwards"});
 990         git_config($projdir, "receive.denyDeleteCurrent", $config{"receive.denydeletecurrent"})
 991                 if exists($config{"receive.denydeletecurrent"}) &&
 992                    $config{"receive.denydeletecurrent"} ne "warn";
 993         git_config($projdir, "core.logAllRefUpdates", "true")
 994                 if $reflogactive;
 995
 996         # Success
 997         if ($makemirror) {
 998                 warn "Mirror project \"$projname\" successfully adopted.\n" unless $quiet;
 999         } else {
1000                 warn "Push project \"$projname\" successfully adopted.\n" unless $quiet;
1001         }
1002         return 0;
1003 }
1004
1005 sub cmd_remove {
1006         my ($force, $reallydel, $keepforks);
1007         parse_options(force => \$force, "really-delete" => \$reallydel,
1008                 "keep-forks" => \$keepforks, quiet => \$quiet, q =>\$quiet);
1009         @ARGV or die "Please give project name on command line.\n";
1010         @ARGV == 1 or die_usage;
1011         my $project = get_project($ARGV[0]);
1012         my $projname = $project->{name};
1013         my $isempty = !$project->{mirror} && $project->is_empty;
1014         if (!$project->{mirror} && !$isempty && $reallydel) {
1015                 die "refusing to remove and delete non-empty push project without --force: $projname\n" unless $force;
1016                 warn "allowing removal and deletion of non-empty push project with --force\n" unless $quiet;
1017         }
1018         my $altwarn;
1019         my $removenogc;
1020         if ($project->has_forks) {
1021                 die "refusing to remove project with forks (use --keep-forks): $projname\n" unless $keepforks;
1022                 warn "allowing removal of forked project while preserving its forks with --keep-forks\n" unless $quiet;
1023                 # Run pseudo GC on that repository so that objects don't get lost within forks
1024                 my $basedir = $Girocco::Config::basedir;
1025                 my $projdir = $project->{path};
1026                 warn "We have to run pseudo GC on the repo so that the forks don't lose data. Hang on...\n" unless $quiet;
1027                 my $nogcrunning = sub {
1028                         die "Error: GC appears to be currently running on $projname\n"
1029                                 if -e "$projdir/gc.pid" || -e "$projdir/.gc_in_progress";
1030                 };
1031                 &$nogcrunning;
1032                 $removenogc = ! -e "$projdir/.nogc";
1033                 recreate_file("$projdir/.nogc") if $removenogc;
1034                 die "unable to create \"$projdir/.nogc\"\n" unless -e "$projdir/.nogc";
1035                 delete $ENV{show_progress};
1036                 $ENV{'show_progress'} = 1 unless $quiet;
1037                 sleep 2; # *cough*
1038                 &$nogcrunning;
1039                 system("$basedir/toolbox/perform-pre-gc-linking.sh", "--include-packs", $projname) == 0
1040                         or die "Running pseudo GC on project $projname failed\n";
1041                 $altwarn = 1;
1042         }
1043         my $archived;
1044         if (!$project->{mirror} && !$isempty && !$reallydel) {
1045                 $archived = $project->archive_and_delete;
1046                 unlink("$archived/.nogc") if $removenogc && defined($archived) && $archived ne "";
1047         } else {
1048                 $project->delete;
1049         }
1050         warn "Project '$projname' removed from $Girocco::Config::name" .
1051                 ($archived ? ", backup in '$archived'" : "") .".\n" unless $quiet;
1052         warn "Retained forks may now have unwanted objects/info/alternates lines\n" if $altwarn && !$quiet;
1053         return 0;
1054 }
1055
1056 sub cmd_show {
1057         use Data::Dumper;
1058         @ARGV == 1 or die_usage;
1059         my $project = get_clean_project($ARGV[0]);
1060         my %info = %$project;
1061         my $d = Data::Dumper->new([\%info], ['*'.$project->{name}]);
1062         $d->Sortkeys(sub {[sort({lc($a) cmp lc($b)} keys %{$_[0]})]});
1063         print $d->Dump([\%info], ['*'.$project->{name}]);
1064         return 0;
1065 }
1066
1067 sub cmd_listheads {
1068         @ARGV == 1 or die_usage;
1069         my $project = get_project($ARGV[0]);
1070         my @heads = sort({lc($a) cmp lc($b)} $project->get_heads);
1071         my $cur = $project->{HEAD};
1072         defined($cur) or $cur = '';
1073         my $curmark = '*';
1074         my $headhash = get_git("--git-dir=$project->{path}", 'rev-parse', '--quiet', '--verify', 'HEAD');
1075         defined($headhash) or $headhash = '';
1076         chomp $headhash;
1077         $headhash or $curmark = '!';
1078         foreach (@heads) {
1079                 my $mark = $_ eq $cur ? $curmark : ' ';
1080                 print "$mark $_\n";
1081         }
1082         return 0;
1083 }
1084
1085 sub cmd_listtags {
1086         my $vcnt = 0;
1087         shift(@ARGV), $vcnt=1 if @ARGV && ($ARGV[0] eq '--verbose' || $ARGV[0] eq '-v');
1088         @ARGV == 1 or die_usage;
1089         my $project = get_project($ARGV[0]);
1090         if ($vcnt) {
1091                 print map("$$_[0]\t$$_[1]\n", get_ctag_counts($project));
1092         } else {
1093                 print map("$_\n", $project->get_ctag_names);
1094         }
1095         return 0;
1096 }
1097
1098 sub cmd_deltags {
1099         my $ic = 0;
1100         shift(@ARGV), $ic=1 if @ARGV && $ARGV[0] =~ /^(?:--?ignore-case|-i)$/i;
1101         @ARGV >= 2 or die_usage;
1102         my $project = get_project(shift @ARGV);
1103         my %curtags;
1104         if ($ic) {
1105                 push(@{$curtags{lc($_)}}, $_) foreach $project->get_ctag_names;
1106         } else {
1107                 push(@{$curtags{$_}}, $_) foreach $project->get_ctag_names;
1108         }
1109         my @deltags = ();
1110         my %seentag = ();
1111         my $ctags = join(" ", @ARGV);
1112         $ctags = lc($ctags) if $ic;
1113         foreach (split(/[\s,]+/, $ctags)) {
1114                 next unless exists($curtags{$_});
1115                 $seentag{$_}=1, push(@deltags, $_) unless $seentag{$_};
1116         }
1117         if (!@deltags) {
1118                 warn $project->{name}, ": skipping removal of only non-existent tags\n" unless $quiet;
1119         } else {
1120                 # Avoid touching anything other than the ctags
1121                 foreach my $tg (@deltags) {
1122                         $project->delete_ctag($_) foreach @{$curtags{$tg}};
1123                 }
1124                 $project->_set_changed;
1125                 $project->_set_forkchange;
1126                 warn $project->{name}, ": specified tags have been removed\n" unless $quiet;
1127         }
1128         return 0;
1129 }
1130
1131 sub cmd_addtags {
1132         @ARGV >= 2 or die_usage;
1133         my $project = get_project(shift @ARGV);
1134         my $ctags = join(" ", @ARGV);
1135         $ctags =~ /[^, a-zA-Z0-9:.+#_-]/ and
1136                 die "Content tag(s) \"$ctags\" contain(s) evil character(s).\n";
1137         my $oldmask = umask();
1138         umask($oldmask & ~0060);
1139         my $changed = 0;
1140         foreach (split(/[\s,]+/, $ctags)) {
1141                 ++$changed if $project->add_ctag($_, 1);
1142         }
1143         if ($changed) {
1144                 $project->_set_changed;
1145                 $project->_set_forkchange;
1146         }
1147         umask($oldmask);
1148         my $cnt = ($changed == 1) ? "1 content tag has" : $changed . " content tags have";
1149         warn $project->{name}, ": $cnt been added/updated\n" unless $quiet;
1150         return 0;
1151 }
1152
1153 sub _get_random_val {
1154         my $p = shift;
1155         my $md5;
1156         {
1157                 no warnings;
1158                 $md5 = md5_hex(time . $$ . rand() . join(':',%$p));
1159         }
1160         $md5;
1161 }
1162
1163 sub cmd_chpass {
1164         my $force = 0;
1165         shift(@ARGV), $force=1 if @ARGV && $ARGV[0] eq '--force';
1166         my $random = undef;
1167         pop(@ARGV), $random=lc($ARGV[1]) if @ARGV==2 && $ARGV[1] =~ /^(?:random|unknown)$/i;
1168         @ARGV == 1 or die_usage;
1169         my $project = get_project($ARGV[0]);
1170         die "refusing to change locked password of project \"$ARGV[0]\" without --force\n"
1171                 if $project->is_password_locked;
1172         my ($newpw, $rmsg);
1173         if ($random) {
1174                 if ($random eq "random") {
1175                         die "refusing to set random password without --force\n" unless $force;
1176                         $rmsg = "set to random value";
1177                         $newpw = _get_random_val($project);
1178                 } else {
1179                         die "refusing to set password hash to '$random' without --force\n" unless $force;
1180                         $rmsg = "hash set to '$random'";
1181                         $newpw = $random;
1182                 }
1183         } else {
1184                 $rmsg = "updated";
1185                 if (-t STDIN) {
1186                         print "Changing admin password for project $ARGV[0]\n";
1187                         my $np1 = prompt_noecho_nl_or_die("New password for project $ARGV[0] (echo is off)");
1188                         $np1 ne "" or die "empty passwords are not permitted (brokenness will ensue)\n";
1189                         my $np2 = prompt_noecho_nl_or_die("Retype new password for project $ARGV[0]");
1190                         $np1 eq $np2 or die "Our high-paid security consultants have determined that\n" .
1191                                 "the admin passwords you have entered do not match each other.\n";
1192                         $newpw = $np1;
1193                 } else {
1194                         $newpw = <STDIN>;
1195                         defined($newpw) or die "missing new password on STDIN\n";
1196                         chomp($newpw);
1197                 }
1198         }
1199         $newpw ne "" or die "empty passwords are not permitted (brokenness will ensue)\n";
1200         my $old = $project->{crypt};
1201         $project->{crypt} = (defined($random) && $random ne "random") ? $newpw : scrypt_sha1($newpw);
1202         if (defined($old) && $old eq $project->{crypt}) {
1203                 warn $project->{name}, ": skipping update of password hash to same value\n" unless $quiet;
1204         } else {
1205                 # Avoid touching anything other than the password hash
1206                 $project->_group_update;
1207                 warn $project->{name}, ": admin password $rmsg (new hash stored)\n" unless $quiet;
1208         }
1209         return 0;
1210 }
1211
1212 sub cmd_checkpw {
1213         @ARGV == 1 or die_usage;
1214         my $project = get_project($ARGV[0]);
1215         my $pwhash = $project->{crypt};
1216         defined($pwhash) or $pwhash = "";
1217         if ($pwhash eq "") {
1218                 warn $project->{name}, ": no password required\n" unless $quiet;
1219                 return 0;
1220         }
1221         if ($project->is_password_locked) {
1222                 warn $project->{name}, ": password is locked\n" unless $quiet;
1223                 exit 1;
1224         }
1225         my $checkpw;
1226         if (-t STDIN) {
1227                 $checkpw = prompt_noecho_nl_or_die("Admin password for project $ARGV[0] (echo is off)");
1228                 $checkpw ne "" or warn "checking for empty password as hash (very unlikely)\n" unless $quiet;
1229         } else {
1230                 $checkpw = <STDIN>;
1231                 defined($checkpw) or die "missing admin password on STDIN\n";
1232                 chomp($checkpw);
1233         }
1234         unless (Girocco::CLIUtil::check_passwd_match($pwhash, $checkpw)) {
1235                 warn "password check failure\n" unless $quiet;
1236                 exit 1;
1237         }
1238         warn "admin password match\n" unless $quiet;
1239         return 0;
1240 }
1241
1242 sub cmd_gc {
1243         my ($force, $auto, $redelta, $recompress);
1244         parse_options(force => \$force, quiet => \$quiet, q => \$quiet, auto => \$auto,
1245                 redelta => \$redelta, "no-reuse-delta" => \$redelta, aggressive => \$force,
1246                 recompress => \$recompress, "no-reuse-object" => $recompress);
1247         $force && $auto and die "--force and --auto are mutually exclusive options\n";
1248         @ARGV or die "Please give project name on command line.\n";
1249         @ARGV == 1 or die_usage;
1250         my $project = get_project($ARGV[0]);
1251         delete $ENV{show_progress};
1252         delete $ENV{force_gc};
1253         $quiet or $ENV{"show_progress"} = 1;
1254         $force and $ENV{"force_gc"} = 1;
1255         if (!$auto && !$force && ! -e $project->{path}."/.needsgc") {
1256                 open NEEDSGC, '>', $project->{path}."/.needsgc" and close NEEDSGC;
1257         }
1258         my @args = ($Girocco::Config::basedir . "/jobd/gc.sh", $project->{name});
1259         $redelta && !$recompress and push(@args, "-f");
1260         $recompress and push(@args, "-F");
1261         my $lastgc = $project->{lastgc};
1262         system({$args[0]} @args) != 0 and return 1;
1263         # Do it again Sam, but only if lastgc was set, gc.sh succeeded and now it's not set
1264         if ($lastgc) {
1265                 my $newlastgc = get_git("--git-dir=$project->{path}", 'config', '--get', 'gitweb.lastgc');
1266                 if (!$newlastgc) {
1267                         system({$args[0]} @args) != 0 and return 1;
1268                 }
1269         }
1270         return 0;
1271 }
1272
1273 sub cmd_update {
1274         my ($force, $summary);
1275         parse_options(force => \$force, quiet => \$quiet, q => \$quiet, summary => \$summary);
1276         $quiet && $summary and die "--quiet and --summary are mutually exclusive options\n";
1277         @ARGV or die "Please give project name on command line.\n";
1278         @ARGV == 1 or die_usage;
1279         my $project = get_project($ARGV[0]);
1280         $project->{mirror} or die "Project \"$ARGV[0]\" is a push project, not a mirror project.\n";
1281         delete $ENV{show_progress};
1282         delete $ENV{force_update};
1283         if ($quiet) {
1284                 $ENV{"show_progress"} = 0;
1285         } else {
1286                 $ENV{"show_progress"} = ($summary ? 1 : 2);
1287         }
1288         $force and $ENV{"force_update"} = 1;
1289         system($Girocco::Config::basedir . "/jobd/update.sh", $project->{name}) != 0 and return 1;
1290         return 0;
1291 }
1292
1293 sub cmd_remirror {
1294         my $force = 0;
1295         parse_options(force => \$force, quiet => \$quiet, q => \$quiet);
1296         @ARGV or die "Please give project name on command line.\n";
1297         @ARGV == 1 or die_usage;
1298         my $project = get_project($ARGV[0]);
1299         $project->{mirror} or die "Project \"$ARGV[0]\" is a push project, not a mirror project.\n";
1300         if ($project->{clone_in_progress} && !$project->{clone_failed}) {
1301                 warn "Project \"$ARGV[0]\" already seems to have a clone underway at this moment.\n" unless $quiet && $force;
1302                 exit(255) unless $force;
1303                 yes_to_continue_or_die("Are you sure you want to force a remirror");
1304         }
1305         unlink($project->_clonefail_path);
1306         unlink($project->_clonelog_path);
1307         recreate_file($project->_clonep_path);
1308         my $sock = IO::Socket::UNIX->new($Girocco::Config::chroot.'/etc/taskd.socket') or
1309                 die "cannot connect to taskd.socket: $!\n";
1310         select((select($sock),$|=1)[0]);
1311         $sock->print("clone ".$project->{name}."\n");
1312         # Just ignore reply, we are going to succeed anyway and the I/O
1313         # would apparently get quite hairy.
1314         $sock->flush();
1315         sleep 2; # *cough*
1316         $sock->close();
1317         warn "Project \"$ARGV[0]\" remirror initiated.\n" unless $quiet;
1318         return 0;
1319 }
1320
1321 sub cmd_setowner {
1322         my $force = 0;
1323         shift(@ARGV), $force=1 if @ARGV && $ARGV[0] eq '--force';
1324         @ARGV == 2 || (@ARGV == 1 && !$force && !$setopt) or die_usage;
1325         my $project = get_project($ARGV[0]);
1326         if (@ARGV == 2 && !valid_email($ARGV[1])) {
1327                 die "invalid owner/email (use --force to accept): \"$ARGV[1]\"\n"
1328                         unless $force;
1329                 warn "using invalid owner/email with --force\n" unless $quiet;
1330         }
1331         if (@ARGV == 2 && length($ARGV[1]) > 96) {
1332                 die "owner/email longer than 96 chars (use --force to accept): \"$ARGV[1]\"\n"
1333                         unless $force;
1334                 warn "using longer than 96 char owner/email with --force\n" unless $quiet;
1335         }
1336         my $old = $project->{email};
1337         if (@ARGV == 1) {
1338                 print "$old\n" if defined($old);
1339                 return 0;
1340         }
1341         if (defined($old) && $old eq $ARGV[1]) {
1342                 warn $project->{name}, ": skipping update of owner/email to same value\n" unless $quiet;
1343         } else {
1344                 # Avoid touching anything other than "gitweb.owner"
1345                 $project->_property_fput("email", $ARGV[1]);
1346                 $project->_update_index;
1347                 $project->_set_changed;
1348                 warn $project->{name}, ": owner/email updated to \"$ARGV[1]\"\n" unless $quiet;
1349         }
1350         return 0;
1351 }
1352
1353 sub cmd_setdesc {
1354         my $force = 0;
1355         shift(@ARGV), $force=1 if @ARGV && $ARGV[0] eq '--force';
1356         @ARGV >= 2 || (@ARGV == 1 && !$force && !$setopt) or die_usage;
1357         my $project = get_project(shift @ARGV);
1358         if (@ARGV && !valid_desc(join(" ", @ARGV))) {
1359                 die "invalid description (use --force to accept): \"".join(" ", @ARGV)."\"\n"
1360                         unless $force;
1361                 warn "using invalid description with --force\n" unless $quiet;
1362         }
1363         my $desc = clean_desc(join(" ", @ARGV));
1364         if (@ARGV && length($desc) > 1024) {
1365                 die "description longer than 1024 chars (use --force to accept): \"$desc\"\n"
1366                         unless $force;
1367                 warn "using longer than 1024 char description with --force\n" unless $quiet;
1368         }
1369         my $old = $project->{desc};
1370         if (!@ARGV) {
1371                 print "$old\n" if defined($old);
1372                 return 0;
1373         }
1374         if (defined($old) && $old eq $desc) {
1375                 warn $project->{name}, ": skipping update of description to same value\n" unless $quiet;
1376         } else {
1377                 # Avoid touching anything other than description file
1378                 $project->_property_fput("desc", $desc);
1379                 $project->_set_changed;
1380                 warn $project->{name}, ": description updated to \"$desc\"\n" unless $quiet;
1381         }
1382         return 0;
1383 }
1384
1385 sub cmd_setreadme {
1386         my $force = 0;
1387         shift(@ARGV), $force=1 if @ARGV && $ARGV[0] eq '--force';
1388         @ARGV == 2 || (@ARGV == 1 && !$force && !$setopt) or die_usage;
1389         my $project = get_project($ARGV[0]);
1390         my $old = $project->{README};
1391         if (@ARGV == 1) {
1392                 chomp $old if defined($old);
1393                 print "$old\n" if defined($old) && $old ne "";
1394                 return 0;
1395         }
1396         my ($new, $raw, $newname);
1397         $newname = '';
1398         if ($ARGV[1] eq "-") {
1399                 local $/;
1400                 $new = <STDIN>;
1401                 $raw = 1;
1402                 $newname = "contents of <STDIN>";
1403         } elsif (lc($ARGV[1]) eq "automatic" || lc($ARGV[1]) eq "auto") {
1404                 $new = "";
1405         } elsif (lc($ARGV[1]) eq "suppressed" || lc($ARGV[1]) eq "suppress") {
1406                 $new = "<!-- suppress -->";
1407         } else {
1408                 my $fn = $ARGV[1];
1409                 $fn =~ s/^\@//;
1410                 die "missing filename for README\n" unless $fn ne "";
1411                 die "no such file: \"$fn\"\n" unless -f $fn && -r $fn;
1412                 open F, '<', $fn or die "cannot open \"$fn\" for reading: $!\n";
1413                 local $/;
1414                 $new = <F>;
1415                 close F;
1416                 $raw = 1;
1417                 $newname = "contents of \"$fn\"";
1418         }
1419         defined($new) or $new = '';
1420         $project->{README} = to_utf8($new, 1);
1421         $project->_cleanup_readme;
1422         if (length($project->{README}) > 8192) {
1423                 die "readme greater than 8192 chars is too long (use --force to override)\n"
1424                         unless $force;
1425                 warn "using readme greater than 8192 chars with --force\n" unless $quiet;
1426         }
1427         if ($raw) {
1428                 my $rd = get_readme_desc($project->{README});
1429                 if ($rd ne "automatic" && $rd ne "suppressed") {
1430                         my $xmllint = qx(command -v xmllint); chomp $xmllint;
1431                         if (-f $xmllint && -x $xmllint) {
1432                                 my ($cnt, $err) = $project->_lint_readme(0);
1433                                 if ($cnt) {
1434                                         my $msg = "xmllint: $cnt error";
1435                                         $msg .= "s" unless $cnt == 1;
1436                                         print STDERR "$msg\n", "-" x length($msg), "\n", $err
1437                                                 unless $force && $quiet;
1438                                         exit(255) unless $force;
1439                                         warn $project->{name} . ": using invalid raw HTML with --force\n" unless $quiet;
1440                                 }
1441                         } else {
1442                                 die "xmllint not available, refusing to use raw HTML without --force\n"
1443                                         unless $force;
1444                                 warn "xmllint not available using unchecked raw HTML with --force\n" unless $quiet;
1445                         }
1446                 }
1447         }
1448         if (defined($old) && $old eq $project->{README}) {
1449                 warn $project->{name}, ": skipping update of README to same value\n" unless $quiet;
1450         } else {
1451                 # Avoid touching anything other than README.html file
1452                 $project->_property_fput("README", $project->{README});
1453                 $project->_set_changed;
1454                 my $desc = get_readme_desc($project->{README});
1455                 if ($newname) {
1456                         $newname .= " ($desc)";
1457                 } else {
1458                         $newname = $desc;
1459                 }
1460                 warn $project->{name}, ": README updated to $newname\n" unless $quiet;
1461         }
1462         return 0;
1463 }
1464
1465 sub valid_head {
1466         my ($proj, $newhead) = @_;
1467         my %okheads = map({($_ => 1)} $proj->get_heads);
1468         exists($okheads{$newhead});
1469 }
1470
1471 sub cmd_sethead {
1472         @ARGV == 2 || (@ARGV == 1 && !$setopt) or die_usage;
1473         my $project = get_project($ARGV[0]);
1474         if (@ARGV == 2 && !valid_head($project, $ARGV[1])) {
1475                 die "invalid head (try \"@{[basename($0)]} listheads $ARGV[0]\"): \"$ARGV[1]\"\n";
1476         }
1477         my $old = $project->{HEAD};
1478         if (@ARGV == 1) {
1479                 print "$old\n" if defined($old);
1480                 return 0;
1481         }
1482         if (defined($old) && $old eq $ARGV[1]) {
1483                 warn $project->{name}, ": skipping update of HEAD symref to same value\n" unless $quiet;
1484         } else {
1485                 # Avoid touching anything other than the HEAD symref
1486                 $project->set_HEAD($ARGV[1]);
1487                 $project->_set_changed;
1488                 warn $project->{name}, ": HEAD symref updated to \"refs/heads/$ARGV[1]\"\n" unless $quiet;
1489         }
1490         return 0;
1491 }
1492
1493 sub cmd_sethooks {
1494         my $force = 0;
1495         shift(@ARGV), $force=1 if @ARGV && $ARGV[0] eq '--force';
1496         @ARGV == 2 || (@ARGV == 1 && !$force && !$setopt) or die_usage;
1497         my $project = get_project($ARGV[0]);
1498         my $projconfig = read_config_file_hash($project->{path}."/config");
1499         my $ghp = $Girocco::Config::reporoot."/_global/hooks";
1500         my $rghp = realpath($ghp);
1501         my $lhp = $project->{path}."/hooks";
1502         my $rlhp = realpath($lhp);
1503         my $ahp = "";
1504         my $rahp = undef;
1505         if (defined($projconfig) && defined($projconfig->{"core.hookspath"})) {
1506                 $ahp = $projconfig->{"core.hookspath"};
1507                 $rahp = realpath($ahp);
1508         }
1509         if (@ARGV == 1) {
1510                 if (defined($rahp) && $rahp ne "") {
1511                         if ($rahp eq $rghp) {
1512                                 my $nc = ($ahp eq $ghp ? "" : " non-canonical");
1513                                 printf "%s \t(global%s)\n", $ahp, $nc;
1514                         } elsif ($rahp eq $rlhp) {
1515                                 my $nc = ($ahp eq $lhp ? "" : " non-canonical");
1516                                 printf "%s \t(local%s)\n", $ahp, $nc;
1517                         } elsif ($rahp ne $ahp) {
1518                                 print "$ahp \t($rahp)\n";
1519                         } else {
1520                                 print "$ahp\n";
1521                         }
1522                 } elsif ($ahp ne "") {
1523                         print "$ahp \t(non-existent)\n";
1524                 }
1525                 return 0;
1526         }
1527         my $shp = $ARGV[1];
1528         if (lc($shp) eq "global") {
1529                 $shp = $ghp;
1530         } elsif (lc($shp) eq "local") {
1531                 $shp = $lhp;
1532         } elsif (substr($shp, 0, 2) eq "~/") {
1533                 $shp = $ENV{"HOME"}.substr($shp,1);
1534         } elsif ($shp =~ m,^~([a-zA-Z_][a-zA-Z_0-9]*)((?:/.*)?)$,) {
1535                 my $sfx = $2;
1536                 my $hd = (getpwnam($1))[7];
1537                 $shp = $hd . $sfx if defined($hd) && $hd ne "" && $hd ne "/" && -d $hd;
1538         }
1539         $shp ne "" && -d $shp or die "no such directory: $ARGV[1]\n";
1540         my $rshp = realpath($shp);
1541         defined($rshp) && $rshp ne "" or die "could not realpath: $ARGV[1]\n";
1542         $rshp =~ m,^/[^/], or die "invalid hookspath: $rshp\n";
1543         die "refusing to switch from current non-global hookspath without --force\n"
1544                 if !$force && defined($rahp) && $rahp ne "" && $rahp ne $rghp && $rshp ne $rahp;
1545         if (!$force && defined($rahp) && $rahp ne "") {
1546                 if ($rshp eq $rahp && ($ahp eq $ghp || $ahp eq $lhp)) {
1547                         warn $project->{name}, ": skipping update of hookspath to same effective value\n" unless $quiet;
1548                         return 0;
1549                 }
1550         }
1551         $rshp = $ghp if $rshp eq $rghp;
1552         $rshp = $lhp if $rshp eq $rlhp;
1553         if ($rshp eq $ahp) {
1554                 warn $project->{name}, ": skipping update of hookspath to same value\n" unless $quiet;
1555                 return 0;
1556         }
1557         die "refusing to set neither local nor global hookspath without --force\n"
1558                 if !$force && $rshp ne $ghp && $rshp ne $lhp;
1559         system($Girocco::Config::git_bin, '--git-dir='.$project->{path},
1560                 'config', "core.hookspath", $rshp);
1561         my $newval = '"'.$rshp.'"';
1562         $newval = "global" if $rshp eq $ghp;
1563         $newval = "local" if $rshp eq $lhp;
1564         warn $project->{name}, ": hookspath set to $newval\n" unless $quiet;
1565         return 0;
1566 }
1567
1568 our %boolfields;
1569 BEGIN {
1570         %boolfields = (
1571                 cleanmirror   => 1,
1572                 reverseorder  => 0,
1573                 summaryonly   => 0,
1574                 statusupdates => 1,
1575         );
1576 }
1577
1578 sub cmd_setbool {
1579         my $force = 0;
1580         shift(@ARGV), $force=1 if @ARGV && $ARGV[0] eq '--force';
1581         @ARGV == 3 || (@ARGV == 2 && !$force && !$setopt) or die_usage;
1582         my $project = get_project($ARGV[0]);
1583         if (!exists($boolfields{$ARGV[1]})) {
1584                 die "invalid boolean field name: \"$ARGV[1]\" -- try \"help\"\n";
1585         }
1586         if (@ARGV == 3 && $boolfields{$ARGV[1]} && !$project->{mirror}) {
1587                 die "invalid boolean field for non-mirror (use --force to accept): \"$ARGV[1]\"\n"
1588                         unless $force;
1589                 warn "using mirror field on non-mirror with --force\n" unless $quiet;
1590         }
1591         if (@ARGV == 3 && !valid_bool($ARGV[2])) {
1592                 die "invalid boolean value: \"$ARGV[2]\"\n";
1593         }
1594         my $bool = clean_bool($ARGV[2]);
1595         my $old = $project->{$ARGV[1]};
1596         if (@ARGV == 2) {
1597                 print "$old\n" if defined($old);
1598                 return 0;
1599         }
1600         if (defined($old) && $old eq $bool) {
1601                 warn $project->{name}, ": skipping update of $ARGV[1] to same value\n" unless $quiet;
1602         } else {
1603                 # Avoid touching anything other than $ARGV[1] field
1604                 $project->_property_fput($ARGV[1], $bool);
1605                 warn $project->{name}, ": $ARGV[1] updated to $bool\n" unless $quiet;
1606         }
1607         return 0;
1608 }
1609
1610 sub cmd_setautogchack {
1611         @ARGV == 2 || (@ARGV == 1 && !$setopt) or die_usage;
1612         my $project = get_project($ARGV[0]);
1613         my $aghok = $Girocco::Config::autogchack &&
1614                 ($project->{mirror} || $Girocco::Config::autogchack ne "mirror");
1615         my $old = defined($project->{autogchack}) ? clean_bool($project->{autogchack}) : "unset";
1616         if (@ARGV == 1) {
1617                 print "$old\n" if $aghok;
1618                 return 0;
1619         }
1620         my $bool;
1621         if (lc($ARGV[1]) eq "unset") {
1622                 $bool = "unset";
1623         } else {
1624                 valid_bool($ARGV[1]) or die "invalid boolean value: \"$ARGV[1]\"\n";
1625                 $bool = clean_bool($ARGV[1]);
1626         }
1627         if (!$aghok) {
1628                 die "\$Girocco::Config::autogchack is false\n" unless $Girocco::Config::autogchack;
1629                 die "\$Girocco::Config::autogchack is only enabled for mirrors\n";
1630         }
1631         if ($old eq $bool) {
1632                 warn $project->{name}, ": autogchack value unchanged\n" unless $quiet;
1633         } else {
1634                 if ($bool eq "unset") {
1635                         system($Girocco::Config::git_bin, '--git-dir='.$project->{path},
1636                                 'config', '--unset', "girocco.autogchack");
1637                 } else {
1638                         system($Girocco::Config::git_bin, '--git-dir='.$project->{path},
1639                                 'config', '--bool', "girocco.autogchack", $bool);
1640                 }
1641         }
1642         return system($Girocco::Config::basedir . "/jobd/maintain-auto-gc-hack.sh", $project->{name}) == 0
1643                 ? 0 : 1;
1644 }
1645
1646 sub valid_url {
1647         my ($url, $type) = @_;
1648         $type ne 'baseurl' and return valid_web_url($url);
1649         valid_repo_url($url) or return 0;
1650         if ($Girocco::Config::restrict_mirror_hosts) {
1651                 my $mh = extract_url_hostname($url);
1652                 is_dns_hostname($mh) or return 0;
1653                 !is_our_hostname($mh) or return 0;
1654         }
1655         return 1;
1656 }
1657
1658 our %urlfields;
1659 BEGIN {
1660         %urlfields = (
1661                 baseurl    => ["url"       , 1],
1662                 homepage   => ["hp"        , 0],
1663                 notifyjson => ["notifyjson", 0],
1664         );
1665 }
1666
1667 sub cmd_seturl {
1668         my $force = 0;
1669         shift(@ARGV), $force=1 if @ARGV && $ARGV[0] eq '--force';
1670         @ARGV == 3 || (@ARGV == 2 && !$force && !$setopt) or die_usage;
1671         my $project = get_project($ARGV[0]);
1672         if (!exists($urlfields{$ARGV[1]})) {
1673                 die "invalid URL field name: \"$ARGV[1]\" -- try \"help\"\n";
1674         }
1675         if (@ARGV == 3 && ${$urlfields{$ARGV[1]}}[1] && !$project->{mirror}) {
1676                 die "invalid URL field for non-mirror (use --force to accept): \"$ARGV[1]\"\n"
1677                         unless $force;
1678                 warn "using mirror field on non-mirror with --force\n" unless $quiet;
1679         }
1680         if (@ARGV == 3 && !valid_url($ARGV[2], $ARGV[1])) {
1681                 die "invalid URL (use --force to accept): \"$ARGV[2]\"\n"
1682                         unless $force;
1683                 warn "using invalid URL with --force\n" unless $quiet;
1684         }
1685         my $old = $project->{${$urlfields{$ARGV[1]}}[0]};
1686         if (@ARGV == 2) {
1687                 print "$old\n" if defined($old);
1688                 return 0;
1689         }
1690         if (defined($old) && $old eq $ARGV[2]) {
1691                 warn $project->{name}, ": skipping update of $ARGV[1] to same value\n" unless $quiet;
1692         } else {
1693                 # Avoid touching anything other than $ARGV[1]'s field
1694                 $project->_property_fput(${$urlfields{$ARGV[1]}}[0], $ARGV[2]);
1695                 if ($ARGV[1] eq "baseurl") {
1696                         $project->{url} = $ARGV[2];
1697                         $project->_set_bangagain;
1698                 }
1699                 $project->_set_changed unless $ARGV[1] eq "notifyjson";
1700                 warn $project->{name}, ": $ARGV[1] updated to $ARGV[2]\n" unless $quiet;
1701         }
1702         return 0;
1703 }
1704
1705 our %msgsfields;
1706 BEGIN {
1707         %msgsfields = (
1708                 notifymail => 1,
1709                 notifytag  => 1,
1710         );
1711 }
1712
1713 sub cmd_setmsgs {
1714         my $force = 0;
1715         shift(@ARGV), $force=1 if @ARGV && $ARGV[0] eq '--force';
1716         @ARGV >= 3 || (@ARGV == 2 && !$force && !$setopt) or die_usage;
1717         my $project = get_project(shift @ARGV);
1718         my $field = shift @ARGV;
1719         if (!exists($msgsfields{$field})) {
1720                 die "invalid msgs field name: \"$field\" -- try \"help\"\n";
1721         }
1722         if (@ARGV && !valid_addrlist(@ARGV)) {
1723                 die "invalid email address list (use --force to accept): \"".join(" ",@ARGV)."\"\n"
1724                         unless $force;
1725                 warn "using invalid email address list with --force\n" unless $quiet;
1726         }
1727         my $old = $project->{$field};
1728         if (!@ARGV) {
1729                 printf "%s\n", clean_addrlist($old, " ") if defined($old);
1730                 return 0;
1731         }
1732         my $newlist = clean_addrlist(join(" ",@ARGV));
1733         if (defined($old) && $old eq $newlist) {
1734                 warn $project->{name}, ": skipping update of $field to same value\n" unless $quiet;
1735         } else {
1736                 # Avoid touching anything other than $field's field
1737                 $project->_property_fput($field, $newlist);
1738                 warn $project->{name}, ": $field updated to \"$newlist\"\n" unless $quiet;
1739         }
1740         return 0;
1741 }
1742
1743 sub cmd_setusers {
1744         my $force = 0;
1745         shift(@ARGV), $force=1 if @ARGV && $ARGV[0] eq '--force';
1746         @ARGV >= 2 || (@ARGV == 1 && !$force && !$setopt) or die_usage;
1747         my $project = get_project(shift @ARGV);
1748         my $projname = $project->{name};
1749         !@ARGV || !$project->{mirror} or die "cannot set users list for mirror project: \"$projname\"\n";
1750         my @newusers = ();
1751         if (@ARGV) {
1752                 eval {@newusers = validate_users(join(" ", @ARGV), $force); 1;} or exit 255;
1753                 die "refusing to set empty users list without --force\n" unless @newusers || $force;
1754         }
1755         return 0 if !@ARGV && $project->{mirror};
1756         my $oldusers = $project->{users};
1757         if ($oldusers && ref($oldusers) eq "ARRAY") {
1758                 $oldusers = join("\n", @$oldusers);
1759         } else {
1760                 $oldusers = "";
1761         }
1762         if (!@ARGV) {
1763                 print "$oldusers\n" if $oldusers ne "";
1764                 return 0;
1765         }
1766         if ($oldusers eq join("\n", @newusers)) {
1767                 warn "$projname: skipping update of users list to same value\n" unless $quiet;
1768         } else {
1769                 # Avoid touching anything other than the users list
1770                 $project->{users} = \@newusers;
1771                 $project->_update_users;
1772                 warn "$projname: users list updated to \"@{[join(',',@newusers)]}\"\n" unless $quiet;
1773         }
1774         return 0;
1775 }
1776
1777 our %fieldnames;
1778 BEGIN {
1779         %fieldnames = (
1780                 owner         => [\&cmd_setowner,      0],
1781                 desc          => [\&cmd_setdesc,       0],
1782                 description   => [\&cmd_setdesc,       0],
1783                 readme        => [\&cmd_setreadme,     0],
1784                 head          => [\&cmd_sethead,       0],
1785                 HEAD          => [\&cmd_sethead,       0],
1786                 hooks         => [\&cmd_sethooks,      0],
1787                 hookspath     => [\&cmd_sethooks,      0],
1788                 cleanmirror   => [\&cmd_setbool,       1],
1789                 reverseorder  => [\&cmd_setbool,       1],
1790                 summaryonly   => [\&cmd_setbool,       1],
1791                 statusupdates => [\&cmd_setbool,       1],
1792                 autogchack    => [\&cmd_setautogchack, 0],
1793                 baseurl       => [\&cmd_seturl,        1],
1794                 homepage      => [\&cmd_seturl,        1],
1795                 notifyjson    => [\&cmd_seturl,        1],
1796                 notifymail    => [\&cmd_setmsgs,       1],
1797                 notifytag     => [\&cmd_setmsgs,       1],
1798                 users         => [\&cmd_setusers,      0],
1799         );
1800 }
1801
1802 sub do_getset {
1803         $setopt = shift;
1804         my @newargs = ();
1805         push(@newargs, shift) if @_ && $_[0] eq '--force';
1806         my $field = $_[1];
1807         (($setopt && @_ >= 3) || @_ == 2) && exists($fieldnames{$field}) or die_usage;
1808         push(@newargs, shift);
1809         shift unless ${$fieldnames{$field}}[1];
1810         push(@newargs, @_);
1811         diename(($setopt ? "set " : "get ") . $field);
1812         @ARGV = @newargs;
1813         &{${$fieldnames{$field}}[0]}(@ARGV);
1814 }
1815
1816 sub cmd_get {
1817         do_getset(0, @_);
1818 }
1819
1820 sub cmd_set {
1821         do_getset(1, @_);
1822 }
1823
1824 our %commands;
1825 BEGIN {
1826         %commands = (
1827                 list => \&cmd_list,
1828                 create => \&cmd_create,
1829                 adopt => \&cmd_adopt,
1830                 remove => \&cmd_remove,
1831                 trash => \&cmd_remove,
1832                 delete => \&cmd_remove,
1833                 show => \&cmd_show,
1834                 listheads => \&cmd_listheads,
1835                 listtags => \&cmd_listtags,
1836                 listctags => \&cmd_listtags,
1837                 deltags => \&cmd_deltags,
1838                 delctags => \&cmd_deltags,
1839                 addtags => \&cmd_addtags,
1840                 addctags => \&cmd_addtags,
1841                 chpass => \&cmd_chpass,
1842                 checkpw => \&cmd_checkpw,
1843                 gc => \&cmd_gc,
1844                 update => \&cmd_update,
1845                 remirror => \&cmd_remirror,
1846                 setowner => \&cmd_setowner,
1847                 setdesc => \&cmd_setdesc,
1848                 setdescription => \&cmd_setdesc,
1849                 setreadme => \&cmd_setreadme,
1850                 sethead => \&cmd_sethead,
1851                 sethooks => \&cmd_sethooks,
1852                 sethookspath => \&cmd_sethooks,
1853                 setbool => \&cmd_setbool,
1854                 setboolean => \&cmd_setbool,
1855                 setflag => \&cmd_setbool,
1856                 setautogchack => \&cmd_setautogchack,
1857                 seturl => \&cmd_seturl,
1858                 setmsgs => \&cmd_setmsgs,
1859                 setusers => \&cmd_setusers,
1860                 get => \&cmd_get,
1861                 set => \&cmd_set,
1862         );
1863 }
1864
1865 sub dohelp {
1866         my $cmd = shift;
1867         my $bn = basename($0);
1868         printf "%s version %s\n\n", $bn, $VERSION;
1869         if (defined($cmd) && $cmd ne '') {
1870                 $cmd =~ s/^set(?=[a-zA-Z])//i;
1871                 my $cmdhelp = '';
1872                 my ($lastmt, $incmd);
1873                 foreach (split('\n', sprintf($help, $bn))) {
1874                         $lastmt || $incmd or $lastmt = /^\s*$/, next;
1875                         $incmd = 1 if $lastmt && /^\s*(?:\[?set\]?)?$cmd\s/;
1876                         last if $incmd && /^\s*$/;
1877                         $incmd and $cmdhelp .= $_ . "\n";
1878                         $lastmt = /^\s*$/;
1879                 }
1880                 print $cmdhelp and exit 0 if $cmdhelp;
1881         }
1882         printf $help, $bn;
1883         exit 0;
1884 }
1885
1886 sub main {
1887         local *ARGV = \@_;
1888         shift, $quiet=1 if @ARGV && $ARGV[0] =~ /^(?:-q|--quiet)$/i;
1889         dohelp($ARGV[1]) if !@ARGV || @ARGV && $ARGV[0] =~ /^(?:-h|-?-help|help)$/i;
1890         my $command = shift;
1891         diename($command);
1892         $setopt = 1;
1893         if (!exists($commands{$command}) && exists($commands{"set".$command})) {
1894                 $setopt = 0;
1895                 $command = "set" . $command;
1896         }
1897         exists($commands{$command}) or die "Unknown command \"$command\" -- try \"help\"\n";
1898         dohelp($command) if @ARGV && ($ARGV[0] =~ /^(?:-h|-?-help)$/i ||
1899                 $ARGV[0] =~ /^help$/i && !Girocco::Project::does_exist("help",1));
1900         &{$commands{$command}}(@ARGV);
1901 }