view release on metacpan or  search on metacpan

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

    }
    $el->[2]=~s/^\s+//;
    $el->[2]=~s/\s+$//;
    my $extra_style="";
    if( $r->param("ysize_${block}_$el->[1]")=~/(\d+)/ ) {
      $extra_style=" style=\"height: ${1}px\"";
    }
    push @{$current->{a}}, +{
			     o=>$el->[1],
			     a=>$el->[2],
			     id=>$el->[3]||'',
			     c=>$el->[4]||'',
			     extra_style=>$extra_style,
			    };
  }
  $stash->{BL}=\@l;

  $prov->stop;

  unless( @l ) {
    my $err="ERROR: Blocklist empty for (Key: $key, Uri: $uri)";
    $err=~s/[\0-\37\177-\377]/ /g;
    $r->log_reason($err);
    $r->err_headers_out->{'X-Error'}=$err;
    $r->err_headers_out->{'X-ErrorCode'}=1;
    return Apache2::Const::SERVER_ERROR;
  }

  $I->tt->process('fetch.html', $stash, $r)
    or do {
      my $err=$I->tt->error;
      $r->log_reason($err);
      $err=~s/[\0-\37\177-\377]/ /g;
      $r->err_headers_out->{'X-Error'}=$err;
      return Apache2::Const::SERVER_ERROR;
    };

  return Apache2::Const::OK;
}

sub xupdate {
  my ($I, $r)=@_;

  my $prov=$I->provider;
  my $stash={q=>$r, I=>$I};
  my ($okey, $key, $ouri, $uri)=map {$r->param($_)} qw/key newkey
						       uri newuri/;
  $prov->start;

 RETRY: {
    eval {
      $prov->begin;

      my ($oblock, $block, $oorder, $order, $id, $action, $note);
      foreach my $a ($r->param) {
	if( ($oblock, $block, $oorder, $order, $id)=
	    $a=~/^action_(\d*)_(\d+)_(\d*)_(\d+)_(\d*)/ ) {
	  $action=$r->param($a);
	  $note=$r->param("note_${block}_${order}");
	  if( length $id ) {
	    die "ERROR: Key=$okey, Uri=$ouri, Block=$oblock, Order=$oorder, Id=$id not updated\n"
	      unless( 0<$prov->update( [$okey, $ouri, $oblock, $oorder, $id],
				       [$key, $uri, $block, $order, $action, $note] ) );
	  } else {
	    die "ERROR: Key=$key, Uri=$uri, Block=$block, Order=$order not inserted\n"
	      unless( 0<$prov->insert( [$key, $uri, $block, $order, $action, $note] ) );
	  }
	} elsif( ($oblock, $oorder, $id)=
		 $a=~/^delete_(\d*)_(\d+)_(\d*)/ ) {
	  die "ERROR: Key=$okey, Uri=$ouri, Block=$oblock, Order=$oorder, Id=$id not deleted\n"
	    unless( 0<$prov->delete( [$okey, $ouri, $oblock, $oorder, $id] ) );
	}
      }

      $prov->commit
    };

    if($@) {
      if( $@ eq "__RETRY__\n" ) {
	$prov->rollback;
	redo RETRY;
      }
      $r->log_reason( "$@" );
      my $err="$@";
      $err=~s/[\n\0-\37\177-\377]/ /g;
      $r->err_headers_out->{'X-Error'}=$err;

      $prov->rollback;
      $prov->stop;

      $key=$okey;
      $uri=$ouri;

      return Apache2::Const::SERVER_ERROR;
    }
  }

  $prov->stop;

  return $I->xfetch($r, $key, $uri);
}

sub handler : method {
  my ($I, $r)=@_;

  unless( ref($I) ) {
    $I=$I->new(r=>$r);
  }

  my $uri=$r->uri;
  $uri=~s!^.*/!/!;

  unless( $uri eq '/' or $uri eq '/index.html' ) {
    my $f=$I->static.$uri;
    return Apache2::Const::NOT_FOUND unless( -f $f and -r _ );
    my $re=$I->types_re;
    if( $f=~m!\.($re)$!i ) {
      $r->content_type($I->types->{lc $1});
    } else {
      $r->content_type('text/plain');
    }