toolbox/projtool.pl

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