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