#!/usr/bin/perl

use Getopt::Std;
use File::Basename;
use Errno qw(ESRCH ENOENT);
use Algorithm::Diff::Cheap;
use strict;
use warnings;
use File::Temp qw(tempfile);

{

=head1 NAME

File::ShLock - lock against multiple execution

=head1 SYNOPSIS

    use File::ShLock
   
    $lock = new File::ShLock("NAME");
    $lock = new File::ShLock(name => "NAME", basedir => "/var/lock",
                             pid => $$);

    exit $lock unless ref $lock;
   
    ### locked section

    $lock = undef;

=head1 DESCRIPTION

This module implements lock files.

The lock files typically reside in C</var/lock> and contain the process
ID of the program which locked the resource in question.

=cut

    #------------------------------------------------------------------------------
    #
    # End of POD
    #
    #------------------------------------------------------------------------------

    package File::ShLock;
    require 5.002;
    use strict;
	use warnings;

    use File::Basename;
    use Errno qw(EEXIST ESRCH);
    use IO::File;

    use vars qw( $VERSION );
    $VERSION = '0.001';

    #------------------------------------------------------------------------------

=head1 CONSTRUCTOR

   $lock = new File::ShLock("name");

Creates a new lock with the given name.

   $lock = new File::ShLock(name => "name",
                            pid => $pid,
                            basedir => "/var/lock");

If C<name> is an absolute path, the lock will be named by appending
directory inode information to the file's name.


=cut

    #------------------------------------------------------------------------------

    sub new {
        my $class = shift;
        my %options;
        my $lock = IO::File->new;

        if ( @_ == 1 ) {
            %options = ( name => $_[0] );
        }
        elsif ( @_ % 1 ) {
            return "3 Usage: File::ShLock->new(NAME) or (name=>NAME)";
        }
        else {
            %options = @_;
            return "3 Usage: File::ShLock->new(NAME) or (name=>NAME)"
              unless defined $options{name};
        }

        my $lockfile = $options{name};
        my $basedir  = $options{basedir} || "/var/lock";
        my $pid      = $options{pid} || $$;
        return "2 process $pid must be running: $!"
          if not kill( 0, $pid )
          and $! == ESRCH;
        if ( dirname($lockfile) ne "." ) {
            my ( $dev, $ino ) = ( stat dirname $lockfile)[ 0, 1 ];
            $lockfile =
              sprintf( "%s/%s.%x_%x", $basedir, $lockfile, $dev, $ino );
        }
        else {
            $lockfile = "$basedir/$lockfile";
        }
        $options{lockfile} = $lockfile;

        my $ltmp = sprintf( "%s/LTMP.%x", $basedir, $$ );
        unlink($ltmp);
        $lock->open("> $ltmp") or return "2 could not open temp link: $!";
        print $lock $pid, "\n"
          or unlink($ltmp), return "2 could not write temp link: $!";
        ;
        $lock->close or unlink($ltmp), return "2 could not close temp link: $!";
        ;

        unless ( link( $ltmp, $lockfile ) ) {
            unlink($ltmp), return "2 could not link lock: $!" if $! != EEXIST;
            $lock->open($lockfile)
              or unlink($ltmp), return "2 could not open lock: $!";
            my $pid;
            defined( $pid = <$lock> )
              or unlink($ltmp), return "2 could not read lock: $!";
            $pid =~ /^(\d+)$/ and $pid = $1;    # un-taint
            $lock->close;
            unlink($ltmp), return 1 if kill( 0, $pid ) or $! != ESRCH;

### the lock is dead. This code is tricky.
            #process A                        process B
            #
            #link(temp,lock) => fail
            #                                link(temp,lock) => fail
            #  check_lock(lock) => fail
            #                                  check_lock(lock) => fail
            #    unlink(lock)
            #link(temp,lock) => SUCCESS
            #                                    unlink(lock) <= deletes the wrong file
            #                                link(temp,lock) => SUCCESS
### OOPS

            unlink($lockfile) and sleep 15;

            #process A                        process B
            #
            #link(temp,lock) => fail
            #                                link(temp,lock) => fail
            #  check_lock(lock) => fail
            #                                  check_lock(lock) => fail
            #    unlink(lock) and sleep 15
            #SLEEP                               unlink(lock) => fail => no sleep
            #SLEEP                           link(temp,lock) => SUCCESS
            #SLEEP
            #link(temp,lock) => fail

            link( $ltmp, $lockfile )
              or unlink($ltmp), return 1;    ## try again (once)

            #We don't retry more than once. That might or might not cause more subtle
            #intercommunications problems. So we'll repair the lock next time around.

        }
        unlink($ltmp);
        bless \%options, $class;
    }

    sub DESTROY {
        my $self = shift;
        unlink $self->{lockfile};
    }

}

sub usage() {
    print STDERR <<END;
Usage: $0 DATEI -- genderte Datei updaten
       [ -b BAK (Extension fr die alte Dateiversion; Default: lschen) ]
       [ -B # (Blockgre bei mehrzeiligem Input; Default: 1) ]
       [ -c # (Bruchteil der Datei, der sich gendert haben darf) ]
       [ -C # (Kontextgre im diff-Output; Default: 3) ]
       [ -d WHAT (Programm, gestartet nachdem alles OK; Default: nix) ]
       [ -D dir (wechsle in dieses Verzeichnis) ]
       [ -f BLA (Absender der Mail, Mailadresse) ]
       [ -F BLA (Absender der Mail, Fullname) ]
       [ -g WHAT (Generatorprogramm; Default: Lesen von stdin) ]
       [ -l Name (Name der Lockdatei in /var/lock; Default: kein Lock) ]
       [ -L (Fehlermeldung, wenn das Lock existiert; Default: tue nichts) ]
       [ -m BLA (Mail an diese Adresse, wenn Probleme) ]
       [ -M BLA (Mail an diese Adresse, wenn OK) ]
       [ -n (tue nichts) ]
       [ -s # (minimale Dateigre (Input neue Datei)) ]
       [ -S BLA (Subject der Mails) ]
       [ -v (reporte Fortschritt etc.) ]
       Datei
END
    open( STDERR, ">/dev/null" );
    exit(1);
}

our($opt_b, $opt_B, $opt_c, $opt_C, $opt_d, $opt_D, $opt_f, $opt_F, $opt_g,
    $opt_h, $opt_l, $opt_L, $opt_m, $opt_M, $opt_n, $opt_S, $opt_s, $opt_v);
BEGIN {
    &getopts("b:B:c:C:d:D:f:F:g:hl:Lm:M:nS:s:v");

    usage if $opt_h or @ARGV != 1;
}

my $debug    = $opt_n;
my $context  = defined($opt_C) ? $opt_C : 3;
my $faktor   = defined($opt_c) ? $opt_c : 10;
my $block    = defined($opt_B) ? $opt_B : 1;
my $groesse  = defined($opt_s) ? $opt_s : 30;
my $mailfail = defined($opt_m) ? $opt_m : $debug ? "" : "autoupdate-failed\@noris.net";
my $maildone = defined($opt_M) ? $opt_M : $debug ? "" : "autoupdate\@noris.net";
my $sender   = $opt_f || "root\@noris.net";
my $sendname = $opt_F || "Auto-Update";
my $gen      = $opt_g || "";
my $done     = $opt_d || "";
my $lock     = $opt_l || "";
my $errlock  = $opt_L;
my $backup   = $opt_b || "";
my $subject  = $opt_S || "";
my $verbose  = $opt_v;

$|=1 if $opt_v;

if ($opt_D) {
    chdir $opt_D or die "$0: chdir '$opt_D' $!\n";
}

my($errh,$errf) = tempfile();
my($difh,$diff) = tempfile();
my $datei = $ARGV[0];
my $tmpf  = "$datei.$$";
my $lockf;

END {
    unlink $tmpf;
    unlink $errf;
    unlink $diff;
}

my $pid = 0;

sub do_error($;$) {
    my ($msg,$ret) = @_;
	$ret=2 unless defined $ret;

    print STDERR "Fehler: $msg.\n" if -t STDERR and not $debug;
    open( MSG,
        ($mailfail && !$debug) ? "|/usr/sbin/sendmail -f $sender $mailfail" : ">&STDERR" );
    my $subj =
      ( $subject ne "" ) ? "Fehler: $subject" : "Fehler beim Updaten von $datei";
    print MSG <<END unless $debug;
From: $sendname <$sender>
Subject: $subj
To: $mailfail

Beim Updaten von $datei ist ein Fehler aufgetreten:
END
	print MSG "$msg\n";
    if ( -s $errf ) {
		seek($errh,0,0);
        print MSG <<END;

Problem:
END
        while (<$errh>) {
            print MSG;
        }
        close($errh);
    }
    if ( -s $diff ) {
		seek($difh,0,0);
        print MSG <<END;

Diff:
END
        while (<$difh>) {
            print MSG;
        }
        close($difh);
    }
    close MSG;
    undef $lock;
    exit $ret;
}

if ( $lock ne "" ) {
    $lock = new File::ShLock($lock);
    unless ( ref $lock ) {
        doerror($lock) if $errlock;
        exit $lock;
    }
}

if ( $backup ne "" and -f "$datei.$backup" ) {
    unlink("$datei.$backup")
      or do_error "Konnte alte Backupdatei '$datei.$backup' nicht entfernen: $!";
}

# Drei Flle:
# 1- lese von Programm
# 2- lese von STDIN o..
# 3- lese von Datei (d.h STDIN ist seek-bar)
# 4- lese von neuer Datei, geschrieben bei -1- bis -3-

my ($ssame,$sold,$snew) = (0,0,0); # file length
my ($lsame,$lold,$lnew) = (0,0,0); # file lines
my ($iold,$inew) = (0,0);
my $chg = 0;
my %chg;

sub rep() {
	return unless $verbose;
	return if $chg++%100;
	my $lin = "\r";
	while(my($a,$b)=each %chg) {
		$lin .= " $a $b";
	}
	$lin .= " < $iold > $inew";
	print $lin;
}

my $incase;
sub setup_fd {
	my $fd1 = undef;
	my $fd2 = undef;
	if(not defined $incase) {
		if($gen ne "") {
		    $incase = 1;
		} else {
			$! = 0;
			seek(STDIN,0,0);
			$incase = ($! ? 2 : 3);
		}
	}
	if($incase == 1) {
	    $pid = open( $fd1, "-|" );
	    if ( !defined $pid ) {
			die "Cannot fork: $!\n";
			undef $lock;
			exit 1;
	    }
	    elsif ( $pid == 0 ) {
			open( STDERR, ">>$errf" );
			exec($gen);
			die "Kein Generator '$gen': $!\n";
	    }
	} elsif($incase == 2) {
        open( $fd1, "<&STDIN" );
	} elsif($incase == 3) {
        open( $fd1, "<&STDIN" );
		seek( $fd1,0,0 );
	} elsif($incase == 4) {
        open( $fd1, "<", $tmpf );
		seek( $fd1,0,0 );
	}
	my($rd1,$rd2);
	if($incase < 4) {
		$incase = 4;
		my $newf;
		open($newf, ">",$tmpf)
		  or do_error("Konnte $tmpf nicht ffnen: $!");

		$rd1 = sub {
			$inew++; rep();
			my $r = <$fd1>;
			if(defined $r and $r ne "") {
				print $newf $r;
			} else {
				close($newf)
				  or do_error("Konnte $tmpf nicht schlieen: $!");
				close($fd1)
				  or do_error("'$gen' ($datei) hat einen Fehler gemeldet? $?");
			}
			$r;
		};
	} else {
		$rd1 = sub {
			$inew++; rep();
			scalar <$fd1>;
		};
	}

	if(open( $fd2, "$datei" )) {
		$rd2 = sub {
			$iold++; rep();
			scalar <$fd2>;
		};
	} else {
		$rd2 = undef;
	}
	($rd1,$rd2);
}

my($r1,$r2) = setup_fd();
if(not defined $r2) {
	# Datei gibbet nich. Trotzdem lesen, weil stdin kopiert werden muss.
	while(defined (my $s = &$r1())) {
		$snew += length($s);
		$lnew ++;
	}
} else {
	my $di = Algorithm::Diff::Cheap->new($r2,$r1, Blocksize=>$block);
	my @context;
	my $did_context = undef;
	open(DIFF, ">$diff" );

	while(my($k,$s) = $di->Next()) {
		$chg{$k}++;
		rep();
		if($k ne " ") {
			print DIFF "@@@ -".(1+$lsame+$lold)." +".(1+$lsame+$lnew)."\n" unless defined $did_context;
			print DIFF " ",join(" ",@context) if @context;
			print DIFF "$k$s";
			$did_context = 0;
			@context = ();
		} elsif(not defined $did_context) {
			# Remember the last few lines before the next chunk
			shift @context if @context >= $context;
			push(@context, $s);
		} elsif(@context < $context) {
			# Remember lines after the current chunk
			push(@context, $s);
		} else {
			# Print the lines after the current chunk
			print DIFF " ",join(" ",@context) if @context;
			@context = ();
			$did_context = undef;
		}
		if($k eq " ") {
			$ssame += length($s);
			$lsame ++;
		} elsif($k eq "-") {
			$sold += length($s);
			$lold ++;
		} elsif($k eq "+") {
			$snew += length($s);
			$lnew ++;
		} else {
			# ???
		}
	}
	close(DIFF) or do_error("Schreiben des diff schlug fehl: $!");
}
print "\r" if $verbose;

if ($snew+$ssame != -s $tmpf) {
	system("cat $tmpf");
    do_error("Die Datei $tmpf ist ".(-s $tmpf)." Bytes lang,\n"
		. "obwohl ".($ssame+$snew)." geschrieben wurden!");
}

if ( not $lold and not $lnew ) {
    print STDERR "Keine Unterschiede.\n" if -t STDERR;
    undef $lock;
    exit 0;
}

do_error( "Die neue $datei ist nur "
      . ( -s $tmpf )
      . "\nstatt min. $groesse Bytes lang" )
  if -s $tmpf < $groesse;

my($lfakt,$sfakt);
$lfakt = ($lsame+1)/($lold/2+$lnew/2+1);
$sfakt = ($ssame+1)/($sold/2+$snew/2+1);

if( -f $datei ) {
	do_error("Zu viele Unterschiede zu $datei ($lfakt: $lsame -$lold +$lnew)",1)
		if $lfakt < $faktor;
	do_error("Zu viele Unterschiede zu $datei ($sfakt: $ssame -$sold +$snew)",1)
		if $sfakt < $faktor;
	do_error("Update OK ($lfakt: $lsame -$lold +$lnew / $sfakt: $ssame -$sold +$snew)",0) if $debug;
} else {
    open( ERR, ">$diff" );
    print ERR "*** $datei wurde neu angelegt ($lnew / $snew).\n";
    close ERR;
    print STDERR "Neu angelegt ($lnew / $snew).\n" if -t STDERR;
}

if ( $backup ne "" ) {
    link( $datei, "$datei.$backup" )
      or do_error("Link auf Backup $datei.$backup schlug fehl: $!");
}
rename( $tmpf, $datei )
  or do_error("Umbenennen der neuen $datei schlug fehl: $!");

if ( $backup ne "" and $done ne "" ) {
    $pid = fork();
    if ( !defined $pid ) {
        die "Cannot fork: $!\n";
        undef $lock;
        exit 1;
    }
    elsif ( $pid == 0 ) {
        open( STDERR, ">>$errf" );
        exec($done);
        die "Keine Completor '$done': $!\n";
    }
    wait;
    if ( $? or -s $errf ) {
        rename( "$datei.$backup", $datei )
          or do_error("Entfernen der neuen Datei nach Fehler schlug fehl: $!");
        do_error("Fehler ($?) in '$done'");
    }
}

if ( $maildone ne "" ) {
    open( MSG, "|/usr/sbin/sendmail -f $sender $maildone" );
    my $subj = ( $subject ne "" ) ? $subject : "Update: $datei";
    print MSG <<END;
From: $sendname <$sender>
Subject: $subj
To: $maildone

Der Update von $datei war erfolgreich.
END
    if ( open( CHG, $diff ) ) {
        print MSG <<END;

nderungen:
END
        while (<CHG>) {
            print MSG $_;
        }
        close CHG;
    }
    close MSG;
}
print STDERR "Update erfolgreich ($lsame -$lold +$lnew / $ssame -$sold +$snew).\n" if -t STDERR;

if ( $done ne "" and $backup eq "" ) {
    exec($done) or
    do_error "Update von $datei: Konnte '$done' nicht starten: $!";
}

undef $lock;
exit 0;

__END__


=head1 Name

changed-file -- generiert eine Datei neu

=head1 Zusammenfassung

	changed-file
       [ -b BAK (Extension fr die alte Dateiversion; Default: lschen) ]
       [ -B # (Blockgre bei mehrzeiligem Input; Default: 1) ]
       [ -c # (Bruchteil der Datei, der sich gendert haben darf) ]
       [ -C # (Kontextgre im diff-Output; Default: 3) ]
       [ -d WHAT (Programm, gestartet nachdem alles OK; Default: nix) ]
       [ -D dir (wechsle in dieses Verzeichnis) ]
       [ -f BLA (Absender der Mail, Mailadresse) ]
       [ -F BLA (Absender der Mail, Fullname) ]
       [ -g WHAT (Generatorprogramm; Default: Lesen von stdin) ]
       [ -l Name (Name der Lockdatei in /var/lock; Default: kein Lock) ]
       [ -L (Fehlermeldung, wenn das Lock existiert; Default: tue nichts) ]
       [ -m BLA (Mail an diese Adresse, wenn Probleme) ]
       [ -M BLA (Mail an diese Adresse, wenn OK) ]
       [ -n (tue nichts) ]
       [ -s # (minimale Dateigre (Input neue Datei)) ]
       [ -S BLA (Subject der Mails) ]
       Datei

=head1 Beschreibung

Dieses Programm generiert eine Datei neu. Dabei werden Fehler im
generierenden Programm bercksichtigt, eine maximale Anzahl
von nderungen festgeschrieben, und optional eine Mail versendet.

=head2 Optionen

=over 4

=item C<-b Extension>

Die alte Version der Datei wird unter dieser Extension aufgehoben.

Default: Kein Aufheben.

=item C<-B Blockgre>

Der neue platzsparende diff-Algorithmus schlgt bei der ersten
bereinstimmung zu, anstatt die kleinstmgliche nderung zu suchen.
Das ist ungnstig fr Dateien, die Begrenzungszeilen
(geschweifte Klammer o..) enthalten. Mit dieser Option kann man angeben,
wieviele Zeilen als Einheit betrachtet werden sollen.

Default: 1 (keine Bockung).

=item C<-c Anteil>

Anteil der Datei, der sich ndern darf. Genauer: Anzahl der
nderungen in Relation zur originalen Dateilnge. Neue Eintrge
werden hierbei nur zur Hlfte bercksichtigt.

Bei Angabe von 0 sind alle nderungen zulssig.

Default: 10.

=item C<-C Kontext>

Anteil der Zeilen vor und nach jeder nderung, die mit ausgegeben werden
sollen.

Default: 3.

=item C<-d Programm>

Dieses Programm wird nach einem erfolgreichen Update ausgefhrt.

Ist die Option C<-b> ebenfalls angegeben, fhren Fehler in diesem 
Programm dazu, da die alte Datei restauriert wird. Ansonsten wird
dieses Programm direkt ausgefhrt und Exitstatus+stderr werden B<nicht>
bercksichtigt.

=item C<-D Verzeichnis>

Wechsle als allererstes in dieses Verzeichnis.

=item C<-f Adresse>

Absender der Mail.

Default: C<root@noris.net>.

=item C<-F Fullname>

Fullname des Absenders.

Default: C<Autoupdate>.

=item C<-g Programm>

Das die Datei generierende Programm.

Eine Fehlermeldung wird erzeugt, wenn das Programm einen Exitstatus != 0
liefert oder auf stderr schreibt.

Default: Lesen von I<stdin>.

B<Vorsicht>: Wenn von I<stdin> gelesen wird, knnen Fehler im
Generatorprogramm nicht bercksichtigt werden.

=item C<-h>

Kurzhilfe.

=item C<-l Name>

Eine Lockdatei, die gegen mehrfaches Generieren derselben Datei
schtzt, wird in C</var/lock> angelegt.

=item C<-L>

Wenn das Lock existiert, wird eine Fehlermeldung gemailt.

Default: C<changed-file> wird ohne Fehler beendet.

=item C<-m Adresse>

Zieladresse fr Mails, die einen Fehler bei der Generierung der Datei anzeigen.

Default: C<autoupdate-failed@noris.net>.

=item C<-M Adresse>

Zieladresse fr Mails, die eine erfolgreiche Generierung der Datei anzeigen.

Default: C<autoupdate@noris.net>.

=item C<-n>

Tue nichts; es wird keine Mail generiert und die Zieldatei wird nicht
verndert.

=item C<-s Bytes>

Minimale Gre der neu angelegten Datei in Bytes. Default: 30.

=item C<-S Subject>

Subject der gesendeten Mail.

=item C<Datei> ...

Die zu ersetzende Datei.

=back

=cut

