view release on metacpan or  search on metacpan

lib/Apache2/Translation/File.pm  view on Meta::CPAN

  truncate $fh, 0 or
    do {close $fh; die "ERROR: Cannot truncate to $fname: $!\n"};

  my $fmt=">>> %@{[$w_id-1]}s %-${w_key}s %-${w_uri}s %${w_blk}s %${w_ord}s\n";
  printf $fh '#'.$fmt, qw/id key uri blk ord/ or
    do {close $fh; die "ERROR: Cannot write to $fname: $!\n"};
  print $fh "# action\n" or
    do {close $fh; die "ERROR: Cannot write to $fname: $!\n"};

  $fmt=("##################################################################\n".
	">>> %${w_id}s %-${w_key}s %-${w_uri}s %${w_blk}s %${w_ord}s\n%s\n");
  # this sort-thing is not really necessary. It's just to have the saved
  # config file in a particular order for human readability.
  foreach my $v (map {$I->_cache->{$_}} sort keys %{$I->_cache}) {
    foreach my $el (sort {$a->[0] <=> $b->[0] or $a->[1] <=> $b->[1]} @{$v}) {
      printf $fh $fmt, @{$el}[3..5,0..2] or
	do {close $fh; die "ERROR: Cannot write to $fname: $!\n"};
      if( defined $dname and length $el->[6] ) {
	my $notesf=undef;
	if( open $notesf, '>'.File::Spec->catfile($dname, $el->[3]) ) {
	  print $notesf $el->[6];
	  close $notesf;
	} else {
	  warn "WARNING: Cannot open ".File::Spec->catfile($dname, $el->[3]).": $!\n";
	}
      }
      $#{$el}=5;
    }
  }

  select( (select( $fh ), $|=1)[0] );  # flush buffer

  my $time=time;
  $time=$oldtime+1 if( $time<=$oldtime );

  utime( $time, $time, $fname );
  $I->timestamp=$time;

  if( defined $dname ) {
    opendir my($d), $dname;
    if( $d ) {
      my %h=map {($_->[3]=>1)} map {@$_} values %{$I->_cache};
      while( my $el=readdir $d ) {
	unlink File::Spec->catfile($dname, $el) if( $el=~/^\d+$/ and !exists $h{$el} );
      }
      closedir $d;
    }
  }

  close $fh or die "ERROR: Cannot write to $fname: $!\n";

  return "0 but true";
}

sub rollback {
  my $I=shift;			# reread table
  $I->timestamp=0;
  $I->start;
}

sub update {
  my $I=shift;
  my $old=shift;
  my $new=shift;

  my $list=$I->_cache->{join "\0", @{$old}[0,1]};
  return "0 but true" unless( $list );

  if( $old->[oKEY] eq $new->[oKEY] and
      $old->[oURI] eq $new->[oURI] ) {
    # KEY and URI have not changed
    for( my $i=0; $i<@{$list}; $i++ ) {
      if( $list->[$i]->[ID]    == $old->[oID]    and # id
	  $list->[$i]->[BLOCK] == $old->[oBLOCK] and # block
	  $list->[$i]->[ORDER] == $old->[oORDER] ) { # order
	@{$list->[$i]}[BLOCK,ORDER,ACTION,NOTE]
	  = @{$new}[nBLOCK,nORDER,nACTION,nNOTE];
	@{$list}=sort {$a->[BLOCK] <=> $b->[BLOCK] or
		       $a->[ORDER] <=> $b->[ORDER]} @{$list};
	return 1;
      }
    }
  } else {
    die "ERROR: KEY must not contain spaces.\n" if( $new->[0]=~/\s/ );
    die "ERROR: URI must not contain spaces.\n" if( $new->[1]=~/\s/ );

    for( my $i=0; $i<@{$list}; $i++ ) {
      if( $list->[$i]->[ID]    == $old->[oID]    and # id
	  $list->[$i]->[BLOCK] == $old->[oBLOCK] and # block
	  $list->[$i]->[ORDER] == $old->[oORDER] ) { # order
	my ($el)=splice @{$list}, $i, 1;
	delete $I->_cache->{join "\0", @{$old}[oKEY,oURI]} unless( @{$list} );
	@{$el}[KEY,URI,BLOCK,ORDER,ACTION,NOTE]
	  = @{$new}[nKEY,nURI,nBLOCK,nORDER,nACTION,nNOTE];
	my $k=join("\0",@{$new}[nKEY,nURI]);
	if( exists $I->_cache->{$k} ) {
	  push @{$I->_cache->{$k}}, $el;
	  $I->_cache->{$k}=[sort {$a->[BLOCK] <=> $b->[BLOCK] or
				  $a->[ORDER] <=> $b->[ORDER]}
			    @{$I->_cache->{$k}}];
	} else {
	  $I->_cache->{$k}=[$el]
	}
	return 1;
      }
    }
  }
  return "0 but true";
}

sub insert {
  my $I=shift;
  my $new=shift;

  die "ERROR: KEY must not contain spaces.\n" if( $new->[0]=~/\s/ );
  die "ERROR: URI must not contain spaces.\n" if( $new->[1]=~/\s/ );

  my $newid=0;
  foreach my $v (values %{$I->_cache}) {
    foreach my $el (@{$v}) {
      $newid=$el->[3] if( $el->[3]>$newid );