Avanti-W: Log-Datei erzaehlt Maerchen, T. 2

[Thomas Berger]

Liebe Frau Koczian,

> Unfree dbn.tbl
> ren dbn.log sonstwas
> free dbn.tbl
> copy sonstwas sicherungspfad\dbn.log
> del sonstwas
> 
> Richtig verstanden? Oder besser Locktbl und Freetbl benutzen?

Hm, unfree vom Mai 2001 ist hoffentlich netzwerktauglich,
free von Juli 1999 evtl. auch. 
Wenn Sie es bislang schon so gemacht haben, wie Sie es
oben beschreiben (evtl. auch ohne das Umbenennen), und 
avanti hat damit trotzdem ein Problem, deutet das darauf
hin, dass avanti noch nicht netzwerkfaehig ist.

Anbei ein paar Zeilen Perl, mit denen ich es mit Win32::API-Calls
normalerweise selber mache (gerade aus einer funktionierenden
Datei ausgeschnitten, kann sein, dass ein paar "use" fehlen).
Ob der (nur angedeutete) Test auf NT mit aktuelleren Perl-Versionen 
wirklich noch noetig ist, weiss ich nicht. Ein OO-Modul hierfuer
wollte ich schon immer einmal bauen, jedoch...

viele Gruesse
Thomas Berger


use Fcntl;
 # yes: Win32::API and Win32API are quite different animals
use Win32API::File qw(:Func);
use Win32::API;
$UnlockFile = new Win32::API("kernel32", "UnlockFile", [I,N,N,N,N], I)
   or warn $^E;
$LockFile = new Win32::API("kernel32", "LockFile", [I,N,N,N,N], I)
   or warn $^E;

sub copylogtomylog {        # Allegro-Logdatei an tickPERM anhaengen
  my $src = $ALLEGRO_LOG;
  return 1 unless -s $src;

# &log ("", "appending Logfile $src to $PERM", 4);
# $CONSOLE->Title("$Title [Locking Database]");
  lockdb($ALLEGRO_TBL) or return 0;
# $CONSOLE->Title("$Title [Moving Logfile]");
# Umbenennen
  $! = 0;
  renametry: {
      $! = 0;
      rename ($src, "$src.tmp") || suicide ("copylog: cannot rename $src
to $src.tmp");
      if ( $! == 13 ) {
#         &log ("harmlos: ", "permission denied at rename of $src:
trying again.", 4);
          redo renametry;
        }
      elsif ( $! ) {
#         &log ("", "rename error ($!) with $src: trying again.", 1);
          redo renametry;
        }
      else {
          last renametry};
    };
# Sicherheitstest: Eigentlich duerfte niemand mehr arbeiten
  sysopen (SRC, "$src.tmp", O_RDWR) || suicide ("copylog: cannot open
moved Log $src.tmp");
  binmode (SRC);

# Datenbank jetzt Freigeben, Log lesend oeffnen.
# $CONSOLE->Title("$Title [Releasing Database]");
  unlockdb ($ALLEGRO_TBL);

# $CONSOLE->Title("$Title [Copying Logfile]");
  seek (SRC, 0, 0);   # einlesen
  seek (MYLOG, 0, 2);  # anhaengen
  my $buff = '';
  while ( read (SRC, $buff, $BUFFSIZE) ) {
      print MYLOG $buff};
  close (SRC);
  unlink ("$src.tmp") || suicide ("copylog: cannot unlink $src.tmp");
  $CONSOLE->Title("$Title");
  return 1;
}

#
sub lockdb {
  local ($base) = $_[0];
# &log ("", "locking $base", 8);
  if ( $ISNT ) {
    lockinter($base, 1) or return 0}
  else {
      system("$ENV{'-P'}\\locktbl $base")};
# &log ("", "locked $base", 7);
  return 1;
}  

sub unlockdb {
  local ($base) = $_[0];
# &log ("", "unlocking $base", 8);
  if ( $ISNT ) {
      lockinter($base, 0)}
  else {
      system("$ENV{'-P'}\\freetbl $base")}
# &log ("", "unlocked $base", 7);
}

# Everything from now on with Win32-Calls
# (Update doesn't like sysopen or close!)

sub lockinter { 
  my ($file, $action) = @_;    # action: 1 - sperren, 0 - freigeben
  $CONSOLE->Title("$Title [opening TBL]");
  local($NativeHandle) = Win32API::File::createFile($file, "rw ke",
"rw") or suicide("couldn't open .TBL ($^E)");

  my $count = 0;
  $TBLstuck = "";
  while ( 1 ) {
      if (++ $count > 500) {
#         &log("", "cannot lock .TBL (100 retries)", 2);
          $TBLstuck = ".TBL seems to be stuck";
          return 0;
         };
#     $CONSOLE->Title("$Title [obtaining lock($count)]");
      unless ( $LockFile->Call($NativeHandle, 0, 0, 2, 0) ) {
#         &log("", "cannot (win32-)lock .TBL", 8) unless ($MAXDEB < 8);
          millisleep(50);
          next;
        };
      my $byte = getstate();
      unless ( defined $byte ) { suicide("couldn't get state") };
      if ( numstate($byte) ) {  # gesperrt
#         $CONSOLE->Title("$Title [.TBL is locked($count)]");
          if ( $action ) {     # soll sperren, kann aber nicht
              $UnlockFile->Call($NativeHandle, 0, 0, 2, 0) 
                   or suicide("couldn't unlock");
#             &log("", "cannot (allegro-)lock .TBL", 6);
              millisleep(500);
              next;
            }
          else {              # soll freigeben, kann immer
              $byte = numstate($byte, 0);
              putstate($byte) or suicide("couldn't write a byte");
              $UnlockFile->Call($NativeHandle, 0, 0, 2, 0) 
                   or suicide("couldn't unlock");
              last;
            }             
        }
      else {
#          $CONSOLE->Title("$Title [.TBL is released($count)]");
          if ( $action ) {     # soll sperren
              $byte = numstate($byte, 1);
              putstate($byte) or suicide("couldn't write a byte");
            }
          else {              # soll freigeben
              suicide("bereits freigegeben: Lock broken!");
            }
          $UnlockFile->Call($NativeHandle, 0, 0, 2, 0) 
               or suicide("couldn't unlock");
          last;
        }
    }

  Win32API::File::CloseHandle($NativeHandle) or suicide("could not close
.TBL ($^E)"); 
  return 1;
}

sub millisleep {
  my $timeout = $_[0] || 100;
  $timeout /= 1000;
  select(undef, undef, undef, $timeout);
}

sub getstate {
  my $uNewPos = Win32API::File::SetFilePointer($NativeHandle, 0, [], 0)
or suicide("could not seek ($^E)");
  my $byte = "\xff";
  my $didread = 0;;
  Win32API::File::ReadFile($NativeHandle, $byte, 1, $didread, []);
  suicide("nothing read ($^E)") unless $didread;
  return $byte;
}

sub putstate {
  my $byte = shift;
  my $uNewPos = Win32API::File::SetFilePointer($NativeHandle, 0, [], 0)
or suicide("could not seek ($^E)");
  my $didwrite = 0;
  Win32API::File::WriteFile($NativeHandle, $byte, 1, $didwrite, []) or
suicide("could not write ($^E)");
  suicide("nothing written ($^E)") unless $didwrite;
  $uNewPos = Win32API::File::SetFilePointer($NativeHandle, 0, [], 0) or
suicide("could not seek ($^E)");
  return 1;
}

sub  numstate {
  my $byte = shift;
  my $action = shift;
  if ( $action ) { # flag setzen
      return ($byte |= "\x01") }
  elsif ( defined $action ) { # flag loeschen
      return ($byte &= "\xfe") }
  else { # flag auslesen
      return ( ($byte & "\x01") eq "\x01" )}
}