| 1 | #!/usr/bin/perl |
|---|
| 2 |
|---|
| 3 | # Script to help generate find the .scripts-version files |
|---|
| 4 |
|---|
| 5 | use LockFile::Simple qw(trylock unlock); |
|---|
| 6 | use File::stat; |
|---|
| 7 |
|---|
| 8 | use lib '/mit/scripts/sec-tools/perl'; |
|---|
| 9 |
|---|
| 10 | open(FILE, "</mit/scripts/sec-tools/store/scriptslist"); |
|---|
| 11 | my $dump = "/mit/scripts/sec-tools/store/versions"; |
|---|
| 12 | my $dumpbackup = "/mit/scripts/sec-tools/store/versions-backup"; |
|---|
| 13 |
|---|
| 14 | # try to grab a lock on the version directory |
|---|
| 15 | trylock($dump) || die "Can't acquire lock; lockfile already exists at <$dump.lock>. Another parallel-find may be running. If you are SURE there is not, remove the lock file and retry."; |
|---|
| 16 |
|---|
| 17 | sub unlock_and_die ($) { |
|---|
| 18 | my $msg = shift; |
|---|
| 19 | unlock($dump); |
|---|
| 20 | die $msg; |
|---|
| 21 | } |
|---|
| 22 |
|---|
| 23 | # if the versions directory exists, move it to versions-backup |
|---|
| 24 | # (removing the backup directory if necessary). Then make a new copy. |
|---|
| 25 | if (-e $dump){ |
|---|
| 26 | if (-e $dumpbackup){ |
|---|
| 27 | system("rm -rf $dumpbackup") && unlock_and_die "Can't remove old backup directory $dumpbackup"; |
|---|
| 28 | } |
|---|
| 29 | system("mv", $dump, $dumpbackup) && unlock_and_die "Unable to back up current directory $dump"; |
|---|
| 30 | } |
|---|
| 31 | system("mkdir", $dump) && unlock_and_die "mkdir failed to create $dump"; |
|---|
| 32 |
|---|
| 33 | use Proc::Queue size => 40, debug => 0, trace => 0; |
|---|
| 34 | use POSIX ":sys_wait_h"; # imports WNOHANG |
|---|
| 35 |
|---|
| 36 | # this loop creates new childs, but Proc::Queue makes it wait every |
|---|
| 37 | # time the limit (50) is reached until enough childs exit |
|---|
| 38 |
|---|
| 39 | # Note that we miss things where one volume is inside another if we |
|---|
| 40 | # use -xdev. May miss libraries stuff. |
|---|
| 41 |
|---|
| 42 | sub updatable ($) { |
|---|
| 43 | my $filename = shift; |
|---|
| 44 | for my $l (`fs la "$filename"`) { |
|---|
| 45 | return 1 if ($l =~ /^ system:scripts-security-upd rlidwk/); |
|---|
| 46 | } |
|---|
| 47 | return 0; |
|---|
| 48 | } |
|---|
| 49 |
|---|
| 50 | sub old_version ($) { |
|---|
| 51 | my $dirname = shift; |
|---|
| 52 | open my $h, "$dirname/.scripts-version"; |
|---|
| 53 | chomp (my $v = (<$h>)[-1]); |
|---|
| 54 | return $v; |
|---|
| 55 | } |
|---|
| 56 |
|---|
| 57 | sub version ($) { |
|---|
| 58 | my $dirname = shift; |
|---|
| 59 | $uid = stat($dirname)->uid; |
|---|
| 60 | open my $h, "sudo -u#$uid git --git-dir=$dirname/.git describe --tags --always 2>/dev/null |"; |
|---|
| 61 | chomp($val = <$h>); |
|---|
| 62 | if (! $val) { |
|---|
| 63 | print "Failed to read value for $dirname\n" |
|---|
| 64 | } |
|---|
| 65 | return $val; |
|---|
| 66 | } |
|---|
| 67 |
|---|
| 68 | sub find ($$) { |
|---|
| 69 | my $user = shift; |
|---|
| 70 | my $homedir = shift; |
|---|
| 71 |
|---|
| 72 | open my $files, "find $homedir/web_scripts -xdev -name .scripts-version -o -name .scripts 2>/dev/null |"; |
|---|
| 73 | open my $out, ">$dump/$user"; |
|---|
| 74 | while (my $f = <$files>) { |
|---|
| 75 | chomp $f; |
|---|
| 76 | my $new_style; |
|---|
| 77 | $new_style = ($f =~ s!/\.scripts$!!); |
|---|
| 78 | if (! $new_style) { |
|---|
| 79 | $f =~ s!/\.scripts-version$!!; |
|---|
| 80 | # Don't use .scripts-version of .scripts is around! |
|---|
| 81 | if (-d "$f/.scripts") { |
|---|
| 82 | next; |
|---|
| 83 | } |
|---|
| 84 | } |
|---|
| 85 | if (! updatable($f)) { |
|---|
| 86 | print STDERR "not updatable: $f"; |
|---|
| 87 | next; |
|---|
| 88 | } |
|---|
| 89 | $v = $new_style ? version($f) : old_version($f); |
|---|
| 90 | print $out "$f:$v\n"; |
|---|
| 91 | } |
|---|
| 92 | return 0; |
|---|
| 93 | } |
|---|
| 94 |
|---|
| 95 | while (<FILE>) { |
|---|
| 96 | my ($user, $homedir) = /^([^ ]*) (.*)$/; |
|---|
| 97 | my $f=fork; |
|---|
| 98 | if(defined ($f) and $f==0) { |
|---|
| 99 | if ($homedir !~ m|^/afs/athena| && $homedir !~ m|^/afs/sipb| && $homedir !~ m|^/afs/zone|) { |
|---|
| 100 | print "ignoring foreign-cell $user $homedir\n"; |
|---|
| 101 | exit(0); |
|---|
| 102 | } |
|---|
| 103 | print "$user\n"; |
|---|
| 104 | $ret = find($user, $homedir); |
|---|
| 105 | sleep rand 1; |
|---|
| 106 | exit($ret); |
|---|
| 107 | } |
|---|
| 108 | 1 while waitpid(-1, WNOHANG)>0; # avoids memory leaks in Proc::Queue |
|---|
| 109 | } |
|---|
| 110 |
|---|
| 111 | unlock($dump); |
|---|
| 112 | 1; |
|---|