__PACKAGE__->mk_accessors(
qw/name version retry pause trace timeout defer current_state has_state is_sync time_creation time_open time_used/
);
our
$VERSION
=
do
{
my
@r
=(
q$Revision: 1.16 $
=~/\d+/g);
sprintf
(
"%d"
.
".%02d"
x
$#r
,
@r
); };
Hide Show 40 lines of Pod
sub
new
{
my
$class
=
shift
;
my
%opts
=(
@_
==1 &&
ref
(
$_
[0]))? %{
$_
[0]} :
@_
;
my
$self
={
is_sync
=>
exists
(
$opts
{is_sync})?
$opts
{is_sync} : 1,
retry
=>
exists
(
$opts
{retry})?
$opts
{retry} : 1,
pause
=>
exists
(
$opts
{pause})?
$opts
{pause} : 10,
timeout
=>
exists
(
$opts
{timeout})?
$opts
{timeout} : 0,
defer
=>
exists
(
$opts
{defer})?
$opts
{defer} : 0,
logging
=>
exists
(
$opts
{logging})?
$opts
{logging} :
undef
,
current_state
=>
undef
,
has_state
=>
undef
,
transport
=>
undef
,
time_creation
=>
time
(),
};
if
(
exists
(
$opts
{log_fh}) &&
defined
(
$opts
{log_fh}))
{
$self
->{logging}=[ \
&xmldump_to_filehandle
,
$opts
{log_fh} ];
}
bless
(
$self
,
$class
);
return
$self
;
}
sub
transport_data {
return
shift
->{transport}; }
sub
send
{
my
(
$self
,
$trid
,
$tosend
,
$cb1
,
$cb2
)=
@_
;
Net::DRI::Exception::err_insufficient_parameters()
unless
(
$cb1
&& (
ref
(
$cb1
) eq
'CODE'
));
my
$timeout
=
$self
->timeout();
my
$prevalarm
=
alarm
(0);
my
$c
=0;
my
$ok
=0;
while
(++
$c
<=
$self
->retry())
{
sleep
(
$self
->pause())
if
(
$self
->pause() && (
$c
> 1));
eval
{
local
$SIG
{ALRM}=
sub
{
die
'timeout'
};
alarm
(
$timeout
)
if
(
$timeout
);
$self
->open_connection()
if
(
$self
->has_state() && !
$self
->current_state());
$self
->logging(
$trid
,2,0,1,
$tosend
);
$ok
=
$self
->
$cb1
(
$c
,
$tosend
);
$self
->time_used(
time
());
};
alarm
(0)
if
(
$timeout
);
if
($@)
{
die
($@)
if
(
ref
($@) eq
'Net::DRI::Protocol::ResultStatus'
);
my
$is_timeout
=(!
ref
($@) && ($@=~m/timeout/))? 1 : 0;
$@=Net::DRI::Exception->new(1,
'internal'
,0,
'Error not handled: '
.$@)
unless
ref
($@);
die
($@)
unless
(
$cb2
&& (
ref
(
$cb2
) eq
'CODE'
));
$self
->
$cb2
($@,
$c
,
$is_timeout
,
$ok
);
}
last
if
(
$ok
);
}
Net::DRI::Exception->
die
(0,
'transport'
,4,
'Unable to send message to registry'
)
unless
$ok
;
alarm
(
$prevalarm
)
if
$prevalarm
;
}
sub
receive
{
my
(
$self
,
$trid
,
$cb1
,
$cb2
)=
@_
;
Net::DRI::Exception::err_insufficient_parameters()
unless
(
$cb1
&& (
ref
(
$cb1
) eq
'CODE'
));
my
$timeout
=
$self
->timeout();
my
$prevalarm
=
alarm
(0);
my
$c
=0;
my
$ans
;
while
(++
$c
<=
$self
->retry())
{
sleep
(
$self
->pause())
if
(
$self
->pause() && (
$c
> 1));
eval
{
local
$SIG
{ALRM}=
sub
{
die
'timeout'
};
alarm
(
$timeout
)
if
(
$timeout
);
$ans
=
$self
->
$cb1
(
$c
);
};
alarm
(0)
if
(
$timeout
);
if
($@)
{
my
$is_timeout
=(!
ref
($@) && ($@=~m/timeout/))? 1 : 0;
$@=Net::DRI::Exception->new(1,
'internal'
,0,
'Error not handled: '
.$@)
unless
ref
($@);
die
($@)
unless
(
$cb2
&& (
ref
(
$cb2
) eq
'CODE'
));
$self
->
$cb2
($@,
$c
,
$is_timeout
,
defined
(
$ans
));
}
last
if
(
defined
(
$ans
));
}
Net::DRI::Exception->
die
(0,
'transport'
,5,
'Unable to receive message from registry'
)
unless
defined
(
$ans
);
alarm
(
$prevalarm
)
if
$prevalarm
;
$self
->logging(
$trid
,2,1,1,
$ans
);
return
$ans
;
}
sub
dump_to_filehandle
{
my
(
$fh
,
$tname
,
$tversion
,
$trid
,
$step
,
$dir
,
$type
,
$data
)=
@_
;
my
$c
=(
ref
(
$data
) && UNIVERSAL::can(
$data
,
'as_string'
))?
$data
->as_string() :
$data
;
my
(
$t
,
$v
)=Time::HiRes::gettimeofday();
my
@t
=
localtime
(
$t
);
my
$tp
=
sprintf
(
'%d-%02d-%02d %02d:%02d:%02d.%06d C%sS [%s] '
,1900+
$t
[5],1+
$t
[4],
$t
[3],
$t
[2],
$t
[1],
$t
[0],
$v
,(
$dir
==0)?
'=>'
:
'<='
,
$trid
||
''
).
$c
.
"\n"
;
if
(UNIVERSAL::can(
$fh
,
'print'
))
{
$fh
->
print
(
$tp
);
}
else
{
print
{
$fh
}
$tp
;
}
}
sub
xmldump_to_filehandle
{
my
(
$fh
,
$tname
,
$tversion
,
$trid
,
$step
,
$dir
,
$type
,
$data
)=
@_
;
my
$c
=(
ref
(
$data
) && UNIVERSAL::can(
$data
,
'as_string'
))?
$data
->as_string() :
$data
;
$c
=~s/^\s+//mg;
$c
=~s/\s+$//mg;
$c
=~s/\n/ /g;
$c
=~s/> </></g;
substr
(
$c
,0,4,
''
)
if
index
(
$c
,
'<'
,0) > 0;
dump_to_filehandle(
$fh
,
$tname
,
$tversion
,
$trid
,
$step
,
$dir
,
$type
,
$c
);
}
sub
logging
{
my
(
$self
,
$trid
,
$step
,
$dir
,
$type
,
$data
)=
@_
;
my
$tname
=
$self
->name();
my
$tversion
=
$self
->version();
my
$l
=
$self
->{logging};
return
unless
defined
(
$l
) &&
ref
(
$l
);
if
(
ref
(
$l
) eq
'ARRAY'
)
{
my
(
$fn
,
$p
)=
@$l
;
return
unless
(
ref
(
$fn
) eq
'CODE'
);
$fn
->(
$p
,
$tname
,
$tversion
,
$trid
,
$step
,
$dir
,
$type
,
$data
);
}
elsif
(UNIVERSAL::can(
$l
,
'logging'
))
{
$l
->logging(
$tname
,
$tversion
,
$trid
,
$step
,
$dir
,
$type
,
$data
);
}
}
sub
ping
{
my
$self
=
shift
;
return
unless
$self
->has_state();
Net::DRI::Exception::err_method_not_implemented();
}
sub
open_connection
{
my
$self
=
shift
;
return
unless
$self
->has_state();
Net::DRI::Exception::err_method_not_implemented();
}
sub
end
{
my
$self
=
shift
;
return
unless
$self
->has_state();
Net::DRI::Exception::err_method_not_implemented();
}
1;