use
5.008;
no
warnings
qw(uninitialized)
;
tt provider provider_url
provider_spec r title/
;
our
@CLASS_MEMBERS
;
our
$VERSION
=
'0.01'
;
our
$STATIC
;
$STATIC
=__PACKAGE__;
$STATIC
=~s!::!/!g;
$STATIC
=
$INC
{
$STATIC
.
'.pm'
};
$STATIC
=~s/\.pm$//;
our
%TYPES
=
(
gif
=>
'image/gif'
,
png
=>
'image/png'
,
jpg
=>
'image/jpeg'
,
jpeg
=>
'image/jpeg'
,
ico
=>
'image/x-icon'
,
html
=>
'text/html'
,
shtml
=>
'text/html'
,
css
=>
'text/css'
,
js
=>
'application/x-javascript'
,
);
sub
_config_provider_SPEC {
my
(
$I
)=
@_
;
my
$param
=
$I
->provider_spec;
my
$class
=
$param
->[0];
eval
"use Apache2::Translation::$class;"
;
if
( $@ ) {
warn
"ERROR: Cannot use Apache2::Translation::$class: $@"
if
$@;
eval
"use $class;"
;
die
"ERROR: Cannot use $class: $@"
if
$@;
}
else
{
$class
=
'Apache2::Translation::'
.
$class
;
}
$I
->provider=
$class
->new( @{
$param
}[1..$
local
$"=
';'
;
my
%x
=@{
$param
}[1..$
$I
->title=
"($param->[0]:@{[map qq{$_=$x{$_}}, keys %x]})"
;
}
sub
_fetch_provider_LWP {
my
(
$I
)=
@_
;
my
$ua
=LWP::UserAgent->new;
my
$resp
=
$ua
->get(
$I
->provider_url);
if
(
$resp
->is_success ) {
my
$x
=YAML::Load(
$resp
->content);
if
(
ref
(
$x
) eq
'HASH'
and
exists
$x
->{TranslationProvider} ) {
$I
->provider_spec=
$x
->{TranslationProvider};
$I
->_config_provider_SPEC;
$I
->title=
"@ "
.
$I
->provider_url;
}
}
}
sub
new {
my
$parent
=
shift
;
my
$I
=
bless
{},
ref
(
$parent
)?
ref
(
$parent
):
$parent
;
my
%o
=
@_
;
$I
->static=
$STATIC
;
$I
->templates=
$STATIC
.
'/templates'
;
$I
->types={};
foreach
my
$m
(
@CLASS_MEMBERS
) {
$I
->
$m
=
$o
{
$m
}
if
(
exists
$o
{
$m
} );
}
@{
$I
->types}{
keys
%TYPES
}=
values
%TYPES
;
my
$re
=
join
'|'
,
keys
%{
$I
->types};
$I
->types_re=
qr/$re/
;
unless
(
defined
$I
->tt and
ref
$I
->tt and
$I
->tt->isa(
'Template'
) ) {
$I
->tt=Template->new({
INCLUDE_PATH
=>
$I
->templates,
EVAL_PERL
=>1,
})
or
die
"ERROR: While creating template object: $Template::ERROR\n"
;
}
unless
(
ref
$I
->provider ) {
if
(
length
$I
->provider_url ) {
$I
->provider_url=
$DEFAULTPROVIDERHOST
.
$I
->provider_url
unless
(
$I
->provider_url=~m!^\w+:! );
}
elsif
(
ref
(
$I
->provider_spec) eq
'ARRAY'
) {
$I
->_config_provider_SPEC;
}
elsif
(
length
$INC
{
'Apache2/Translation.pm'
} and
defined
$I
->r ) {
$I
->provider=(Apache2::Module::get_config(
'Apache2::Translation'
,
$I
->r->server) || {})
->{provider};
$I
->title=
"@ "
.
$I
->r->server->server_hostname;
}
unless
(
length
$I
->provider_url ) {
die
"ERROR: Cannot resolve translation provider\n"
unless
(
ref
$I
->provider);
}
}
return
$I
;
}
sub
xindex {
my
(
$I
,
$r
)=
@_
;
my
$prov
=
$I
->provider;
my
$stash
={
q=>$r, I=
>
$I
};
$prov
->start;
my
$k
=
$r
->param(
'key'
);
my
@l
=
$prov
->list_keys_and_uris(
$k
);
$stash
->{PREPROC}=[
grep
{
$_
->[1] eq
':PRE:'
}
@l
];
$stash
->{URIS}=[
grep
{
$_
->[1]=~m!^/!}
@l
];
$stash
->{SUBS}=[
grep
{
$_
->[1]!~m!^(?:/|:PRE:$)!}
@l
];
$stash
->{KEYS}=
[
+{
name
=>
' - not set - '
,
value
=>
''
,
selected
=>
''
},
map
{
+{
name
=>
$_
->[0],
value
=>
$_
->[0],
selected
=>(
$_
->[0] eq
$k
?
"selected"
:
""
) };
}
$prov
->list_keys
];
$prov
->stop;
$I
->tt->process(
'index.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
xfetch {
my
(
$I
,
$r
,
$key
,
$uri
)=
@_
;
my
$prov
=
$I
->provider;
my
$stash
={
q=>$r, I=
>
$I
};
$prov
->start;
my
@l
;
my
$block
;
my
$current
;
$key
=
$r
->param(
'key'
)
unless
(
defined
$key
);
$stash
->{key}=
$key
;
$uri
=
$r
->param(
'uri'
)
unless
(
defined
$uri
);
$stash
->{uri}=
$uri
;
my
$rowspan
;
foreach
my
$el
(
$prov
->fetch(
$key
,
$uri
)) {
if
(
$block
ne
$el
->[0] ) {
$block
=
$el
->[0];
$current
={
b
=>
$block
,
a
=>[] };
push
@l
,
$current
;
}
$el
->[2]=~s/^\s+//;
$el
->[2]=~s/\s+$//;
my
$lines
=(
$el
->[2]=~
tr
/\n//)+1;
$lines
=10
if
(
$lines
>10 );
push
@{
$current
->{a}}, +{
o
=>
$el
->[1],
a
=>
$el
->[2],
lines
=>
$lines
,
id
=>
$el
->[3]||
''
};
}
$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;
eval
{
$prov
->begin;
my
(
$oblock
,
$block
,
$oorder
,
$order
,
$id
,
$action
);
foreach
my
$a
(
$r
->param) {
if
( (
$oblock
,
$block
,
$oorder
,
$order
,
$id
)=
$a
=~/^action_(\d*)_(\d+)_(\d*)_(\d+)_(\d*)/ ) {
$action
=
$r
->param(
$a
);
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
] ) );
}
else
{
die
"ERROR: Key=$key, Uri=$uri, Block=$block, Order=$order not inserted\n"
unless
( 0<
$prov
->insert( [
$key
,
$uri
,
$block
,
$order
,
$action
] ) );
}
}
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
($@) {
$r
->log_reason(
"$@"
);
my
$err
=
"$@"
;
$err
=~s/[\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'
);
}
$r
->sendfile(
$f
);
return
Apache2::Const::OK;
}
unless
(
defined
$I
->provider ) {
$I
->_fetch_provider_LWP
if
(
length
$I
->provider_url);
die
"ERROR: Cannot resolve translation provider\n"
unless
(
ref
$I
->provider);
}
$r
=Apache2::Request->new(
$r
);
$r
->content_type(
'text/html'
);
my
$a
=
$r
->param(
'a'
);
if
(
$a
eq
''
) {
return
$I
->xindex(
$r
);
}
elsif
(
$a
eq
'fetch'
) {
return
$I
->xfetch(
$r
);
}
elsif
(
$a
eq
'update'
) {
return
$I
->xupdate(
$r
);
}
else
{
return
Apache2::Const::NOT_FOUND;
}
return
Apache2::Const::OK;
}
1;