ARCv2
view release on metacpan or search on metacpan
Makefile.PL view on Meta::CPAN
'Term::ReadLine' => '0.0',
},
dist => {
COMPRESS => 'gzip --best',
SUFFIX => 'gz',
PREOP => 'make -C doc'
},
'EXE_FILES' => [ 'scripts/arcx', 'scripts/arcxd' ],
);
sub Usage {
print STDERR <<EOH;
ARCv2 Makefile.PL
Usage: perl $0 [options]
Possible options are:
--help See this help
EOH
opt_help();
$DefaultPort = 4242;
$DefaultHost = "arcdsrv";
$DefaultPIDFile = "/var/run/arcxd.pid";
$Copyright = "ARCv2 $VERSION (C) 2003-5 Patrick Boettcher and others. All right reserved.";
$Contact = "Patrick Boettcher <patrick.boettcher\@desy.de>, Wolfgang Friebel <wolfgang.friebel\@desy.de>";
my @syslog_arr = ('emerg','alert','crit','err','warning','notice','info','debug');
# package member vars
sub members
{
return {
# private:
# protected:
_error => undef, # contains the error message
_syslog => 1, # log to syslog or to STDERR
# public:
loglevel => 7, # loglevel is combination of bits (1=AUTH,2=USER,4=ERR,8=CMDDEBUG,16=VERBSIDE,32=DEBUG) see _Log method
logfileprefix => "", # Prepended to every log entry
logdestination => 'syslog', # Where should all the log output go to ('stderr','syslog')
};
}
## Constructor.
## Initializes the object and returns it blessed.
## For all sub classes, please override C<_Init> to check the
## parameter which are passed to the C<new> function. This
## is necessary because you are not able to call the the new method of a
## parent class, when having a class name (new $class::SUPER::new, does not work.).
##in> %hash, key => val, ...
##out> blessed object of the class
##eg> my $this = new Arc::Class ( key => value, key2 => value2 );
sub new
{
my $this = shift;
my $class = ref($this) || $this;
my $self = bless { },$class;
$self->_Init(@_);
return $self;
}
## Init function (initializes class context)
## Module dependent initialization, every subclass shall override it
## and call the _Init of its SUPER class. This method is called by the new method of C<Arc>.
##in> %hash, key => val, ...
##out> true, if all passed values are in their definition scope, otherwise false
##eg> see source code of any non-abstract sub class of Arc
sub _Init
{
my $this = shift;
my (%values) = @_;
my $members = $this->members;
while (my ($key,$val) = each(%$members)) {
$this->{$key} = exists($values{$key}) ? $values{$key} : $val;
delete $values{$key};
}
openlog("arcv2","cons,pid","user") if $this->{_syslog};
1;
}
## Debug function.
## Logs messages with "DEBUG"
##in> ... (message)
##out> always false
##eg> $this->_Debug("hello","world"); # message will be "hello world"
sub _Debug
{
my $this = shift;
$this->Log(LOG_DEBUG,@_);
}
## Log function.
## Logs messages to 'logdestination' if 'loglevel' is is set appropriatly.
## loglevel behaviour has changed in the 1.0 release of ARCv2, the "Arc"-class can export
## LOG_AUTH (authentication information), LOG_USER (connection information), LOG_ERR (errors),
## LOG_CMD (ARCv2 addition internal command information), LOG_SIDE (verbose client/server-specific
## information), LOG_DEBUG (verbose debug information). It possible to combine the
## levels with or (resp. +) to allow a message to appear when not all loglevels are
## requested by the user.
## Commonly used for logging errors from application level.
##in> $facility, ... (message)
##out> always false
##eg> return $arc->Log(LOG_ERR,"Message");
sub Log
{
my $this = shift;
my $pr = shift;
my $ll = $this->{loglevel};
my $lev = 1;
my @syslog_arr = ('err','info','debug');
$lev = 0 if $pr & LOG_ERR;
$lev = 2 if $pr & LOG_DEBUG;
}
## SetError function.
## This function prepends the error message (@_) to an existing error message (if any) and
## logs the message with LOG_ERR facility.
## Use this function for setting an error from class level. Users should use IsError
## to get the message if a function failed.
##in> ... (message)
##out> always false
##eg> return $this->_SetError("User is not allowed to do this."); # breaks when an error occured
sub _SetError
{
my $this = shift;
$this->Log(LOG_ERR,@_);
my $errstr = "";
if ($this->{_error}) {
$errstr = ' maybe caused by: '.$this->{_error};
}
unless (@_) {
$errstr .= 'Error, but no message.';
}
$errstr =~ s/\r//g;
$errstr =~ s/\n/ /g;
$this->{_error} = $errstr;
return;
}
## User function to get the error msg.
##out> the error message if any otherwise undef
##eg> unless (my $err = $arc->IsError()) { .. } else { print STDERR $err; }
sub IsError
{
my $this = shift;
my $ret = $this->{_error};
$this->{_error} = undef;
return $ret;
}
## Destructor
sub DESTROY {
my $this = shift;
closelog() if $this->{_syslog};
}
1;
lib/Arc.pod view on Meta::CPAN
B<Example:>
return $arc->Log(LOG_ERR,"Message");
=item new ( %hash, key => val, ... )
B<Description>: Constructor.
Initializes the object and returns it blessed.
For all sub classes, please override C<_Init> to check the
parameter which are passed to the C<new> function. This
is necessary because you are not able to call the the new method of a
parent class, when having a class name (new $class::SUPER::new, does not work.).
B<Returns:> blessed object of the class
B<Example:>
lib/Arc.pod view on Meta::CPAN
B<Description>: Init function (initializes class context)
Module dependent initialization, every subclass shall override it
and call the _Init of its SUPER class. This method is called by the new method of C<Arc>.
B<Returns:> true, if all passed values are in their definition scope, otherwise false
B<Example:>
see source code of any non-abstract sub class of Arc
=item _SetError ( ... (message) )
B<Description>: SetError function.
This function prepends the error message (@_) to an existing error message (if any) and
logs the message with LOG_ERR facility.
Use this function for setting an error from class level. Users should use IsError
to get the message if a function failed.
lib/Arc/Command.pm view on Meta::CPAN
package Arc::Command;
use strict;
use warnings;
use Carp;
use Arc;
@Arc::Command::ISA = qw(Arc);
# Friend class Arc::Connection::Server;
sub members
{
my $this = shift;
return { %{$this->SUPER::members},
# private:
# protected:
_commands => {}, # the "available commands"-hash from the server,
_username => "", # user, who has authenticated against ARCv2 Server by using SASL
_realm => "", # the name of the realm, to which the user belongs (SASL)
_mech => undef, # user uses this authentication mechanism (e.g. GSSAPI)
lib/Arc/Command.pm view on Meta::CPAN
# public:
logfileprefix => "command",
};
}
## execute this command.
## This function is called by the ARCv2 Server when the user wants
## to execute this command.
##in> ... (parameter from users request)
##out> true if the command has succeeded, false (and please set _SetError) if not.
sub Execute
{
my $this = shift;
return 1;
}
return 1;
lib/Arc/Command.pod view on Meta::CPAN
| Client | out \ | Server | p1 \
|--------|-<<-\ \ |--------|-<<-\ \
/|\ \|/ /|\ \|/
|--------| |-----------|
| User | | Command |
|--------| |-----------|
This design makes it easy for ARCv2 Commands to get input and produce output.
B<Example>:
sub Execute
{
while ($_ = <STDIN>) { # ends on EOF
s/a/b/g; print;
}
}
If you want to implement a new Command for ARCv2 you have to derive from
Arc::Command and override the sub C<Execute>. See existing Arc::Command::*
classes for examples. To get your Command recognised you have to assign a
B<Command Name> to your command class. ARCv2 ignores the return code of
B<Execute>. If your command runs into an error use the _SetError function
and return immediately. This is what ARCv2 will evaluate and send to the
client.
B<Example>:
sub Execute
{
my $this = shift;
my $pw = <>;
if ($pw ne "klaus") {
return $this->_SetError("Wrong password.");
}
}
In ARCv2 some standard commands are already implemented: C<Arc::Command::Get>,
C<Arc::Command::Put>, C<Arc::Command::Uptime>, C<Arc::Command::Whoami>,
lib/Arc/Command.pod view on Meta::CPAN
B<Example:>
return $arc->Log(LOG_ERR,"Message");
=item new ( %hash, key => val, ... ) I<inherited from Arc>
B<Description>: Constructor.
Initializes the object and returns it blessed.
For all sub classes, please override C<_Init> to check the
parameter which are passed to the C<new> function. This
is necessary because you are not able to call the the new method of a
parent class, when having a class name (new $class::SUPER::new, does not work.).
B<Returns:> blessed object of the class
B<Example:>
lib/Arc/Command.pod view on Meta::CPAN
B<Description>: Init function (initializes class context)
Module dependent initialization, every subclass shall override it
and call the _Init of its SUPER class. This method is called by the new method of C<Arc>.
B<Returns:> true, if all passed values are in their definition scope, otherwise false
B<Example:>
see source code of any non-abstract sub class of Arc
=item _SetError ( ... (message) ) I<inherited from Arc>
B<Description>: SetError function.
This function prepends the error message (@_) to an existing error message (if any) and
logs the message with LOG_ERR facility.
Use this function for setting an error from class level. Users should use IsError
to get the message if a function failed.
lib/Arc/Command/Get.pm view on Meta::CPAN
package Arc::Command::Get;
use strict;
use warnings;
use Carp;
use Arc::Command;
@Arc::Command::Get::ISA = qw(Arc::Command);
sub members
{
my $this = shift;
return { %{$this->SUPER::members},
# private:
# protected:
};
}
sub Execute
{
my $this = shift;
return $this->_SetError("What shall I copy? Please give the filename.") unless @_;
return $this->_SetError($_[0]," not found or is not readable for me. $!") unless (open FH, "<", $_[0]);
print <FH>;
close FH;
}
lib/Arc/Command/Help.pm view on Meta::CPAN
package Arc::Command::Help;
use strict;
use warnings;
use Carp;
use Arc::Command;
@Arc::Command::Help::ISA = qw(Arc::Command);
sub members
{
my $this = shift;
return { %{$this->SUPER::members},
# private:
# protected:
};
}
sub Execute
{
my $this = shift;
print "This is $Arc::Copyright\n";
print "Please report bugs to: $Arc::Contact\n";
print "\n";
print "Available Commands:\n";
# sort command
lib/Arc/Command/Put.pm view on Meta::CPAN
package Arc::Command::Put;
use strict;
use warnings;
use Carp;
use Arc::Command;
@Arc::Command::Put::ISA = qw(Arc::Command);
sub members
{
my $this = shift;
return { %{$this->SUPER::members},
# private:
# protected:
};
}
sub Execute
{
my $this = shift;
return $this->_SetError("No destination filename given!") unless (@_);
return $this->_SetError($_[0]," is not writeable for me. !") unless (open FH, ">".$_[0]);
while ($_ = <STDIN>)
{
print FH $_;
}
lib/Arc/Command/Test.pm view on Meta::CPAN
package Arc::Command::Test;
use strict;
use warnings;
use Carp;
use Arc::Command;
@Arc::Command::Test::ISA = qw(Arc::Command);
sub members
{
my $this = shift;
return { %{$this->SUPER::members},
# private:
# protected:
};
}
sub Execute
{
my $this = shift;
print "Command line arguments: ", join("|",@_),"\n" if @_;
while ($_ = <STDIN>) {
my $y = length($_)/2;
print substr($_,(length($_)-$y)/2,$y),"\n";
}
lib/Arc/Command/Uptime.pm view on Meta::CPAN
package Arc::Command::Uptime;
use strict;
use warnings;
use Carp;
use Arc::Command;
use POSIX qw(setsid);
@Arc::Command::Uptime::ISA = qw(Arc::Command);
sub members
{
my $this = shift;
return { %{$this->SUPER::members},
# private:
# protected:
};
}
sub Execute
{
my $this = shift;
system("uptime");
return 1;
}
return 1;
lib/Arc/Command/Whoami.pm view on Meta::CPAN
package Arc::Command::Whoami;
use strict;
use warnings;
use Arc::Command;
use IO::Socket;
@Arc::Command::Whoami::ISA = qw(Arc::Command);
sub members
{
my $this = shift;
return { %{$this->SUPER::members},
# private:
# protected:
};
}
sub Execute
{
my $this = shift;
my $name = gethostbyaddr(inet_aton($this->{_peeraddr}),AF_INET);
print $this->{_username}," coming from ",$name," [",$this->{_peeraddr},"] Port ",
$this->{_peerport},"\n";
return 1;
}
return 1;
lib/Arc/Connection.pm view on Meta::CPAN
use strict;
use warnings;
use Carp;
use MIME::Base64;
use Arc qw(LOG_AUTH LOG_USER LOG_ERR LOG_CMD LOG_SIDE LOG_DEBUG);
use Authen::SASL;
@Arc::Connection::ISA = qw(Arc);
sub members
{
my $this = shift;
return { %{$this->SUPER::members},
# private:
__sasl => undef, # Authen::SASL Handle
__linequeue => [], # internal line buffer (idea From Net::Cmd)
__partial => "", # a partial line (idea From Net::Cmd)
# protected:
_connection => undef, # IO::Socket for the ARCv2 Connection
_cmdclientsock => undef, # IO::Socket for the command connection (encrypted)
lib/Arc/Connection.pm view on Meta::CPAN
_username => "anonymous", # username extracted from SASL
# public:
protocol => undef, # Which protocol is used (0 = ARC/2.0, 1 = ARC/2.1)
timeout => undef, # timeout for all connections (ARCv2 and command) in seconds
service => undef, # name of the server (for SASL)
};
}
sub _Init
{
my $this = shift;
return $this->_SetError("Initialization failed.") unless $this->SUPER::_Init(@_);
# timeout
# unless (defined $this->{timeout}) {
# $this->Log(LOG_SIDE,"Setting timeout to 30 secs since no time specified.");
# $this->{timeout} = 30;
# }
lib/Arc/Connection.pm view on Meta::CPAN
return $this->_SetError("No service name for SASL authentication specified.")
unless defined $this->{service};
return 1;
}
## initializes command connection. (protocol)
## Starts listen on the Command socket and sends the B<CMDPASV> command.
##out> true if everything went like expected, otherwise false.
##eg> $this->_CommandConnection();
sub _CommandConnection
{
my $this = shift;
my $consock = IO::Socket::INET->new(
Listen => 1,
Proto => 'tcp',
LocalAddr => $this->{_connection}->sockhost,
ReuseAddr => 1,
) || return $this->_SetError("Socket creation for CommandConnection failed.");
lib/Arc/Connection.pm view on Meta::CPAN
## This function is always used by the C<Arc::Connection::Server> to handle
## command data. When calling the C<ProcessCommand> from C<Arc::Connection::Client>
## this function is also used.
## Data is read from the local socket resp. pipe and is written encrypted
## to the network socket. The other side reads the data from network socket,
## decrypts it and writes it to its local socket. This function behaves differently on
## client and server sides, when the local or network socket is closed.
##in> *locfdin, *locfdout
##out> always true
##eg> $this->ReadWriteBinary(*STDIN,*STDOUT);
sub _ReadWriteBinary
{
my $this = shift;
my $locin = shift;
my $locout = shift;
my $client = ref ($this) eq "Arc::Connection::Client";
my $netsock = $this->{_cmdclientsock};
# $this->_Debug("ReadWriteBinary (C:",$client,") locin: ",$locin->fileno,", locout:",$locout->fileno,", net: ",$netsock->fileno);
my $sel = new IO::Select($netsock,$locin);
my $lwsel = new IO::Select($locout);
lib/Arc/Connection.pm view on Meta::CPAN
# $this->_Debug("RW Binary ended.");
return 1;
}
## send a line. (protocol)
## This function sends a command line to the ARCv2 socket.
##in> ... (line)
##out> true if writing has succeeded, otherwise false.
##eg> $this->_SendLine($cmd,"test");
sub _SendLine
{
my $this = shift;
return unless @_;
my $line = join("",@_);
$line =~ s/\r//g;
$line =~ s/\n/ /g;
return $this->_SetError("SendLine only available when connection and select is set.") unless $this->{_connected};
if ($this->{_select}->can_write($this->{timeout})) {
$this->_Debug(substr ($line,0,30),"..");
lib/Arc/Connection.pm view on Meta::CPAN
$this->{_connection}->close;
return $this->_SetError("Sending timed out.");
}
}
## send a command. (protocol)
## Send a command to the ARCv2 socket.
##in> $cmd, $parameter
##out> true if successful, otherwise false
##eg> $this->_SendCommand("CMDPASV",$consock->sockhost.':'.$consock->sockport);
sub _SendCommand
{
my $this = shift;
my ($cmd,$msg) = @_;
my $ret = 1;
$ret = $this->_SetError("Sending command $cmd failed.") unless $this->_SendLine($cmd,defined $msg ? " ".$msg : "");
return $ret;
}
## receive a line (command). (protocol)
## This function receives data from the ARCv2 connection and
## fills the internal C<__linequeue> and C<__partial>. It returns
## a line from the internal buffer if there is any. It also handles
## timeouts and "connection closed by foreign host"'s.
##out> true (and the line) if everything worked fine, otherwise false (undef)
##eg> if (my $line = $this->_RecvLine()) { ... }
sub _RecvLine
{
my $this = shift;
return shift @{$this->{__linequeue}} if scalar @{$this->{__linequeue}};
# no connection is set not connected
return $this->_SetError("RecvCommand only Available when connection and select is set.") unless $this->{_connected};
my $partial = defined($this->{__partial}) ? $this->{__partial} : "";
lib/Arc/Connection.pm view on Meta::CPAN
}
$this->{__partial} = $partial;
return shift @{$this->{__linequeue}};
}
## receives an ARCv2 Command. (protocol)
## This function gets a line from C<_RecvLine> and extracts the ARCv2 command and
## the optional command parameter C<_cmdparameter>.
##out> ARCv2 command and true if everything works fine, otherwise false
##eg> while (my $cmd = $this->_RecvCommand()) { ... }
sub _RecvCommand
{
my $this = shift;
my $command = undef;
if (my $line = $this->_RecvLine()) { # Fetch and parse a cmd from queue
$line =~ s/[\r\n]//g;
($command,$this->{_cmdparameter}) = $line =~ m/^([A-Z]+)\ ?(.*)?$/;
}
return $command; # There was an error if undef is return
}
## process an ARCv2 command. (protocol)
## Process a command by evaling $this->_R$cmd. Also checks if
## this command was expected now (looks into the $this->{_expectedcmds} array).
## Used by client and server.
##in> $cmd
##out> true, if ARCv2 command has been in place, otherwise false
##eg> while (my $cmd = $this->_RecvCommand() && $this->_ProcessLine($cmd)) {}
sub _ProcessLine
{
my $this = shift;
my $cmd = shift;
my $ret = 1;
$this->_Debug("Received Command: $cmd (",@{$this->{_expectedcmds}},")");
if (grep { $_ eq $cmd } @{$this->{_expectedcmds}} ) {
$cmd = "_R".$cmd;
$ret = $this->_SetError("Evaluation of command $cmd failed ($@).")
unless eval { $this->$cmd; }
lib/Arc/Connection.pm view on Meta::CPAN
}
return $ret;
}
## send the ARCv2 SASL command. (protocol)
## This function encodes the output from sasl_*_start and sasl_*_step with Base-64 and sends
## it to the other side
##in> $saslstr
##out> true if successful, otherwise false
##eg> $this->_Sasl($sasl->client_start());
sub _Sasl
{
my ($this,$str) = @_;
return $this->_SendCommand("SASL",encode_base64($str,""));
}
## initialize sasl.
## This function initializes the C<__sasl> member with an object
## of C<Authen::SASL>.
##out> true if successful, otherwise false
##eg> $this->_PrepareAuthentication() || return;
sub _PrepareAuthentication
{
my $this = shift;
# Authen::SASL Instance creation
$this->{__sasl} = Authen::SASL->new(
mechanism => "".$this->{_saslmech},
);
if (!defined $this->{__sasl}) {
return $this->_SetError("SASL error. No SASL object created.");
}
return 1;
}
## are we connected?
##out> true, if the ARCv2 control connection is connected, otherwise false
##eg> last unless $arc->IsConnected;
sub IsConnected
{
my $this = shift;
return $this->{_connected};
}
sub clean
{
my $this = shift;
delete $this->{__sasl};
$this->{__linequeue} = [];
$this->{__partial} = "";
$this->{_authenticated} = 0;
$this->{_sasl} = undef;
$this->{_saslmech} = "";
lib/Arc/Connection.pod view on Meta::CPAN
B<Example:>
return $arc->Log(LOG_ERR,"Message");
=item new ( %hash, key => val, ... ) I<inherited from Arc>
B<Description>: Constructor.
Initializes the object and returns it blessed.
For all sub classes, please override C<_Init> to check the
parameter which are passed to the C<new> function. This
is necessary because you are not able to call the the new method of a
parent class, when having a class name (new $class::SUPER::new, does not work.).
B<Returns:> blessed object of the class
B<Example:>
lib/Arc/Connection/Client.pm view on Meta::CPAN
use Carp;
use IO::Socket::INET;
use IO::Select;
use Arc qw(LOG_AUTH LOG_USER LOG_ERR LOG_CMD LOG_SIDE LOG_DEBUG);
use Arc::Connection;
use MIME::Base64;
@Arc::Connection::Client::ISA = qw(Arc::Connection);
sub members
{
my $this = shift;
return { %{$this->SUPER::members},
logfileprefix => "client",
logdestination => "stderr",
sasl_cb_user => $ENV{'USER'}, # SASL Callback for username (PLAIN and some other mechs only)
sasl_cb_auth => $ENV{'USER'}, # SASL Callback for authname (PLAIN and some other mechs only)
sasl_cb_pass => "", # SASL Callback for password (PLAIN and some other mechs only)
server => undef, # Server to connect to
port => undef, # Port to connect to
sasl_mechanism => undef, # use this mechanism for authentication
server_sasl_mechanisms => [], # filled by the sasl mechanisms
protocol => 1, # Which protocol type the shall use.
};
}
sub _Init
{
my $this = shift;
return 0 unless $this->SUPER::_Init(@_);
# server
return $this->_SetError("No ARCv2 server given.") unless defined $this->{server};
# port
unless (defined $this->{port}) {
lib/Arc/Connection/Client.pm view on Meta::CPAN
}
# sasl mech
$this->Log(LOG_SIDE,"No sasl mechanism specified. Using the one supplied by the server.")
unless defined $this->{sasl_mechanism};
}
## connects to the server
##out> true when succesful, otherwise false
##eg> $this->_Connect();
sub _Connect
{
my $this = shift;
$this->{_connection} = new IO::Socket::INET(
PeerAddr => $this->{server},
PeerPort => $this->{port},
Type => SOCK_STREAM,
) || return $this->_SetError("Could not create Client socket: $! $@.");
# Fill the connected Socket into the select object
lib/Arc/Connection/Client.pm view on Meta::CPAN
$this->{_connection}->autoflush(0);
$this->{_connected} = 1;
return 1;
}
## initialize the protocol.
## Sends the initial protocol message ARC/2.0
##out> true when succesful, otherwise false
##eg> $this->_InitARC2();
sub _InitARC2
{
my $this = shift;
@{$this->{_expectedcmds}} = qw(ERR AUTH);
$this->{_authenticated} = 0;
return $this->_SendCommand ("ARC/2.".$this->{protocol});
}
## initiate the authentication.
## Tells the server which authtype we want to use.
## Protocol command: AUTHENTICATE [<authtype>]\r\n
##out> true when succesful, otherwise false
##eg> $this->_Authenticate();
sub _Authenticate
{
my $this = shift;
@{$this->{_expectedcmds}} = qw(ERR AUTHTYPE);
return $this->_SendCommand ("AUTHENTICATE",$this->{sasl_mechanism});
}
## initiate the authentication (sasl)
## Creates the sasl object (client_new).
## Client begins always and sends the first SASL challenge
## Protocol command: SASL <base64 encoded SASL output>\r\n
##out> true when succesful, otherwise false
##eg> $this->_StartAuthentication();
sub _StartAuthentication
{
my $this = shift;
$this->_PrepareAuthentication() || return;
$this->{__sasl}->callback(
user => $this->{sasl_cb_user},
auth => $this->{sasl_cb_auth},
pass => $this->{sasl_cb_pass},
);
lib/Arc/Connection/Client.pm view on Meta::CPAN
@{$this->{_expectedcmds}} = qw(SASL ERR);
return $this->_StepAuthentication(1);
}
## another SASL step.
## Response of a SASL command from the server.
## Protocol command: SASL <base64 encoded SASL outout>\r\n
##in> $first_step
##out> true when succesful, otherwise false
##eg> return $this->_StepAuthentication(1);
sub _StepAuthentication
{
my $this = shift;
my $first = shift;
my $sasl = $this->{_sasl};
my $ret = 0;
my $str;
if ($first) {
$str = $sasl->client_start();
} else {
lib/Arc/Connection/Client.pm view on Meta::CPAN
$ret = $this->_SetError("SASL: Negotiation failed. User is not authenticated. SASL error: (",$sasl->code,") ",$sasl->error);
}
return $ret
}
## send an ARCv2 command request
## Protocol command: CMD <cmd> <cmdparameter>\r\n
##in> ... (cmd and parameter)
##out> true when succesful, otherwise false
##eg> $this->_Cmd ("whoami");
sub _Cmd
{
my $this = shift;
my $str = join " ",@_;
$str =~ s/[\r\n]//g;
return $this->_SetError("Empty command won't be sent.") unless length $str;
@{$this->{_expectedcmds}} = qw(ERR CMDPASV DONE);
return $this->_SendCommand("CMD",$str);
}
# The _R subs are processing a server response, call resp. subs and set the expectedcmds array approp.
## parses the AUTH <list of SASL mech>\r\n, sent by the server
sub _RAUTH
{
my $this = shift;
@{$this->{server_sasl_mechanisms}} = split(',',$this->{_cmdparameter});
return $this->_Authenticate();
}
## parses the AUTHTYPE <SASL mech>\r\n, sent by the server.
## Which SASL mech the server will use.
sub _RAUTHTYPE
{
my $this = shift;
$this->{_saslmech} = $this->{_cmdparameter};
return $this->_StartAuthentication();
}
## parses the SASL <base64 encoded SASL string>\r\n, sent by the server.
## Sasl response from the server
sub _RSASL
{
my $this = shift;
return $this->_SetError("SASL Negotiation failed.") unless ($this->_StepAuthentication(0));
return 1;
}
## parses the ERR <msg>\r\n, sent by the server.
## Server command, which reports an server-side error
sub _RERR
{
my $this = shift;
$this->_SetError("Server ERROR:",$this->{_cmdparameter});
return 1;
}
## parses the CMDERR <msg>\r\n, sent by the server.
## Command specific error, which reports an error during the command
sub _RCMDERR
{
my $this = shift;
$this->_SetError("Command ERROR:",$this->{_cmdparameter});
return 1;
}
## parses CMDPASV <host:port>\r\n, sent by the server.
## Establish the encrypted command connection.
sub _RCMDPASV
{
my $this = shift;
$this->Log(LOG_SIDE,"Try to connect to:",$this->{_cmdparameter});
@{$this->{_expectedcmds}} = qw(ERR DONE CMDERR);
return if defined $this->{_cmdclientsock};
my ($host,$port) = split(/:/,$this->{_cmdparameter});
lib/Arc/Connection/Client.pm view on Meta::CPAN
PeerAddr => $host,
PeerPort => $port,
Type => SOCK_STREAM,
) || return $this->_SetError("Passive Connection failed.");
return 1;
}
## parses DONE\r\n, sent by the server.
## This is received when a command is done.
sub _RDONE
{
my $this = shift;
@{$this->{_exceptedcmds}} = qw(ERR CMD);
return 1;
}
## start an ARCv2 session.
## This function which will change the status of the connection into a
## authenticated status. Users have to call this function
## to be able to run ARCv2 commands afterwards.
##out> true if authentication was successful, otherwise false.
##eg> if ($arc->StartSession()) { .. }
sub StartSession
{
my $this = shift;
return $this->_SetError("There is already a command running.") if $this->IsConnected();
return $this->_SetError("Connection to host ",$this->{server},":",$this->{port}," failed") unless $this->_Connect();
$this->_InitARC2();
while (!$this->{_error} && ($this->{_authenticated} == 0) && (my $cmd = $this->_RecvCommand())) {
last unless $this->_ProcessLine($cmd);
}
return !$this->{_error} && $this->{_authenticated};
}
## ends the connection.
## Tells the server that we want to end the conversation. (Userlevel)
## Protocol command: QUIT\r\n
##out> always true
##eg> $arc->Quit();
sub Quit
{
my $this = shift;
$this->_SendCommand("QUIT");
$this->{_connection}->close();
$this->{_connected} = 0;
$this->{_expectedcmds} = qw();
return 1;
}
## process a command.
## This function runs a command with STDIN and STDOUT as clients
## in- and output control.
##in> ... (command and its parameters)
##out> true if successful, false if not. (IsError is set appropriatly)
##eg> $arc->ProcessCommand("whoami");
sub ProcessCommand
{
my $this = shift;
return unless $this->CommandStart(@_);
STDOUT->autoflush(1);
$this->_ReadWriteBinary(*STDIN,*STDOUT);
return $this->CommandEnd();
}
## start an ARCv2 command
## This function starts the given ARCv2 Command and enables the Command* functions.
##in> ... (command and its parameters)
##out> true if successful, false if not. (IsError is set appropriatly)
##eg> if ($arc->CommandStart()) { ... }
sub CommandStart
{
my $this = shift;
return $this->_SetError("You are not authenticated.") unless $this->{_authenticated};
return $this->_SetError("Already running a command.") if defined $this->{_cmdclientsock};
return unless @_;
return unless $this->_Cmd(@_);
while (!$this->{_error} && (not defined $this->{_cmdclientsock}) && (my $cmd = $this->_RecvCommand()) ) {
$this->_ProcessLine($cmd);
last if $cmd eq "DONE";
}
return 1 if defined $this->{_cmdclientsock};
return;
}
## write something to the command.
## Write something to the standard input of the command started by C<CommandStart>.
##in> ... (data)
##out> true if successful, false if not. (IsError is set appropriatly)
##eg> last unless $this->CommandWrite();
sub CommandWrite
{
my $this = shift;
return $this->_SetError("There is no command running.") unless defined $this->{_cmdclientsock};
return unless @_;
my $str = join("",@_);
$str = $this->{_sasl}->encode($str);
return $this->{_cmdclientsock}->syswrite($str);
}
## close the write part of the netsock.
## This function closes the write-part of the command connection.
##out> true if successful, false if not. (IsError is set appropriatly)
##eg> last unless $arc->CommandEOF();
sub CommandEOF
{
my $this = shift;
return $this->_SetError("There is no command running.") unless defined $this->{_cmdclientsock};
return shutdown($this->{_cmdclientsock},1);
}
## read data from the Command connection.
##out> if successful the received data is returned, otherwise false.
##eg> while (my $data = $arc->CommandRead()) { ... }
sub CommandRead
{
my $this = shift;
return $this->_SetError("There is no command running.") unless defined $this->{_cmdclientsock};
my $sel = new IO::Select ( $this->{_cmdclientsock} );
my $buf;
while ($sel->can_read($this->{timeout})) {
return unless $this->{_cmdclientsock}->sysread($buf,1024);
$buf = $this->{_sasl}->decode($buf);
next unless $buf; # SASL incomplete decode
return $buf;
}
return;
}
## end the command on the server side.
## Closes the command connection and ends the command.
##out> true if successful, false if not. (IsError is set appropriatly)
##eg> $arc->CommandEnd();
sub CommandEnd
{
my $this = shift;
return $this->_SetError("There is no command running.") unless defined $this->{_cmdclientsock};
if ($this->{protocol} == 1) {
# encrypted protocol and command connection, don't lose synchronized sasl_de/encode
$this->CommandEOF();
while ($_ = $this->CommandRead()) { $this->_Debug("read text: ".$_); };
}
lib/Arc/Connection/Client.pod view on Meta::CPAN
if ($arc->StartSession) {
$arc->CommandStart("test");
$arc->CommandWrite("hallo\n");
if (my $t = $arc->CommandRead()) {
print $t,"\n"; # should give 'all'
}
$arc->CommandEnd();
}
sub username
{
return $ENV{'USER'};
}
sub password
{
return <>;
}
=head1 Class VARIABLES
=head3 PUBLIC MEMBERS
=over 2
lib/Arc/Connection/Client.pod view on Meta::CPAN
B<Example:>
return $arc->Log(LOG_ERR,"Message");
=item new ( %hash, key => val, ... ) I<inherited from Arc>
B<Description>: Constructor.
Initializes the object and returns it blessed.
For all sub classes, please override C<_Init> to check the
parameter which are passed to the C<new> function. This
is necessary because you are not able to call the the new method of a
parent class, when having a class name (new $class::SUPER::new, does not work.).
B<Returns:> blessed object of the class
B<Example:>
lib/Arc/Connection/Server.pm view on Meta::CPAN
use IO::Select;
use IO::Pipe;
use IO::Socket::INET;
use Arc qw(LOG_AUTH LOG_USER LOG_ERR LOG_CMD LOG_SIDE LOG_DEBUG);
use Arc::Connection;
use MIME::Base64;
@Arc::Connection::Server::ISA = qw(Arc::Connection);
sub members
{
my $this = shift;
return { %{$this->SUPER::members},
_realm => "", # Name of the SASL realm, if the user is from the default realm, this is empty
logfileprefix => "server",
sasl_cb_getsecret => "", # Callback for SASL (if PLAIN (or equal) mechanisms are used). See Authen::SASL(::Cyrus).
sasl_cb_checkpass => 0, # Callback for SASL (if PLAIN (or equal) mechanisms are used). See Authen::SASL(::Cyrus).
sasl_mechanisms => undef, # array of allowed SASL mechanisms
commands => undef, # hash of assignment between B<Command Name> and B<Command Class>. See L<Arc::Command>
};
}
sub _Init
{
my $this = shift;
return unless $this->SUPER::_Init(@_);
# sasl_mechanisms
return $this->_SetError("No SASL mechanisms given.")
unless defined $this->{sasl_mechanisms};
# commands
return $this->_SetError("No ARCv2 commands given. There is no reason the run ARCv2.")
unless defined $this->{commands};
}
## Callback function to canonicalize the username (SASL)
## see Authen::SASL(::Cyrus) for parameter list and how to use.
sub _CBCanonUser
{
my ($this,$type,$realm,$maxlen,$user) = @_;
return $user;
}
## send the available SASL mechanisms.
## Protocol command: AUTH <comma-seperated list of SASL mechansims>\r\n
##out> true when succesful, otherwise false
##eg> $this->_Auth();
sub _Auth
{
my $this = shift;
@{$this->{_expectedcmds}} = qw(QUIT AUTHENTICATE);
return $this->_SendCommand("AUTH",join (",",@{$this->{sasl_mechanisms}}));
}
## send an error msg to client (Server error).
## Protocol command: ERR <msg>\r\n
##out> true when succesful, otherwise false
##eg> $this->_Error("failure.");
sub _Error
{
my $this = shift;
return $this->_SendCommand("ERR",join("",@_));
}
## send a command error msg to client.
## Protocol command: CMDERR <msg>\r\n
##out> true when succesful, otherwise false
##eg> $this->_CmdError("failure.");
sub _CmdError
{
my $this = shift;
return $this->_SendCommand("CMDERR",join("",@_));
}
## command is ready.
## When the ARCv2 command is ready with its work, the server
## sends the DONE command on the control connection.
## Protocol command: DONE\r\n
##out> true when succesful, otherwise false
##eg> $this->_Done();
sub _Done
{
my $this = shift;
return $this->_SendCommand("DONE");
}
## tell the client, which SASL mechanism is used.
## Protocol command: AUTHTYPE <SASL mechansism>\r\n
##out> true when succesful, otherwise false
##eg> $this->_Authtype();
sub _Authtype
{
my $this = shift;
@{$this->{_expectedcmds}} = qw(QUIT SASL);
return $this->_SendCommand("AUTHTYPE",$this->{_saslmech});
}
## Creates the sasl object (server_new)
## and sends the first sasl challenge/response.
## Protocol command: SASL <base64 encoded SASL output>\r\n
##out> true when succesful, otherwise false
##eg> $this->_StartAuthentication();
sub _StartAuthentication
{
my $this = shift;
$this->_PrepareAuthentication() || return;
# Setting the Callback for getting the username
# This has to happen just before the object-creation of cyrus sasl
# because there is no way to set a callback after sasl_*_new
$this->{__sasl}->callback(
canonuser => [ \&_CBCanonUser, $this ],
lib/Arc/Connection/Server.pm view on Meta::CPAN
return $this->_StepAuthentication(1);
}
## Another SASL step
## Response of a SASL command from the client
## Protocol command: SASL <base64 encoded SASL outout>\r\n
##in> bool $first_step
##out> true when succesful, otherwise false
##eg> $this->_StepAuthentication(1);
sub _StepAuthentication
{
my $this = shift;
my $first = shift;
my $sasl = $this->{_sasl};
my $ret = 0;
my $str;
if ($first) {
if ($this->{_cmdparameter} =~ /^\s+$/) {
$this->_Debug("No cmdparameter, plain server start.");
lib/Arc/Connection/Server.pm view on Meta::CPAN
}
} else {
$ret = $this->_Error("SASL: Negotiation failed. User is not authenticated. (",$sasl->code,") ",
$sasl->error);
}
return $ret;
}
## parses the AUTHENTICATE[ <SASL mech>]\r\n, sent by the client.
## Checks if the demanded SASL mechanism is allowed and returns the
## selected mechanism.
sub _RAUTHENTICATE
{
my $this = shift;
if ( $this->{_cmdparameter} ne "") {
if (grep ({ $_ eq $this->{_cmdparameter}} @{$this->{sasl_mechanisms}} )) {
$this->{_saslmech} = $this->{_cmdparameter};
} else {
return $this->_Error("SASL mechanism not allowed by server.");
}
} else {
$this->_Debug("Default Sasl: ",@{$this->{sasl_mechanisms}}[0]);
$this->{_saslmech} = @{$this->{sasl_mechanisms}}[0];
}
return $this->_Authtype();
}
## parses the SASL <base64 encoded SASL string>\r\n, sent by the client.
## Sasl challenge/response from the client
sub _RSASL
{
my $this = shift;
my $ret;
if (!defined $this->{_sasl}) {
$ret = $this->_StartAuthentication() || die "Sasl StartAuthentication failed.";
} else {
$ret = $this->_StepAuthentication() || die "Sasl StepAuthentication failed.";
}
return $ret;
}
## See source code for this method. /dev/null for unwanted output.
sub tonne {
}
## parses the CMD <cmd>\r\n, sent by the client.
## check if the command exists, prepares the command connection, executes the command and
## does cleanups after execution.
sub _RCMD
{
my $this = shift;
my ($cmd,$para) = split(/\s+/,$this->{_cmdparameter},2);
$this->_Error("Command not found.") unless defined $cmd;
my $perlcmd = $this->{commands}->{$cmd};
my $reason = $this->_CheckCmd($cmd, $perlcmd);
if (defined $reason) {
lib/Arc/Connection/Server.pm view on Meta::CPAN
$SIG{__WARN__} = 'DEFAULT';
if ($this->{_error}) {
$this->_Debug("_RCMD ended with an error");
} else {
$this->_Debug("_RCMD ended ok");
}
return !$this->{_error};
}
sub _CheckCmd
{
my $this = shift;
my ($cmd, $perlcmd) = @_;
# Do nothing by default.
# This method is mearly here so a sub-class can override it.
return undef;
}
sub _SplitCmdArgs
{
my $this = shift;
my $para = shift;
return split(/\s+/,$para) if defined $para; # better splitting for array TODO
return ();
}
sub _RunCmd
{
my $this = shift;
my ($cmd, $perlcmd, $argref) = @_;
my $cmderr;
my $ret = eval {
my $object = new $perlcmd (
_commands => $this->{commands},
_username => $this->{_username},
_realm => $this->{_realm},
lib/Arc/Connection/Server.pm view on Meta::CPAN
return 0;
};
$ret = 2 unless defined($ret);
$cmderr .= " ".$@ if $@;
return ($ret, $cmderr);
}
## does nothing, placeholder for QUIT\r\n command, sent by the client.
sub _RQUIT
{
my $this = shift;
return 1;
}
## Public function, gets the clientsocket (from Arc::Server) and handles it.
## Handles a connection (main loop).
##in> $clientsock (IO::Socket)
##out> true on success, otherwise false
##eg> $arc->HandleClient(sock);
sub HandleClient
{
my $this = shift;
return $this->_SetError("Client socket needed.") unless (@_ == 1);
my $client = shift;
# Fill the connected Socket into the select object
$this->{_connection} = $client;
$this->{_connected} = 1;
$this->{_select} = new IO::Select( $client );
lib/Arc/Connection/Server.pm view on Meta::CPAN
return $line;
}
}
return !$this->{_error};
}
## Ends the connection.
## Do some cleanup.
##out> always true
##eg> $arc->Quit();
sub Quit
{
my $this = shift;
$this->{_connection}->close if ($this->{_connection});
$this->{_connected} = 0;
delete $this->{_sasl};
$this->{_authenticated} = 0;
1;
}
lib/Arc/Connection/Server.pod view on Meta::CPAN
B<Example:>
return $arc->Log(LOG_ERR,"Message");
=item new ( %hash, key => val, ... ) I<inherited from Arc>
B<Description>: Constructor.
Initializes the object and returns it blessed.
For all sub classes, please override C<_Init> to check the
parameter which are passed to the C<new> function. This
is necessary because you are not able to call the the new method of a
parent class, when having a class name (new $class::SUPER::new, does not work.).
B<Returns:> blessed object of the class
B<Example:>
lib/Arc/Server.pm view on Meta::CPAN
use strict;
use warnings;
use Carp;
use Net::Server::PreFork;
use IO::Socket;
use Arc qw(LOG_AUTH LOG_USER LOG_ERR LOG_CMD LOG_SIDE LOG_DEBUG);
@Arc::Server::ISA = qw(Arc Net::Server::PreFork);
sub members
{
my $this = shift;
return { %{$this->SUPER::members},
# private:
__arc => undef, # stores the Arc::Connection::Server object for optimal PreFork
# protected:
# public:
connection_type => 'Arc::Connection::Server', # Class to use for connections
connection_vars => undef, # variables passed directly to every connection handle See C<Arc::Connection::Server>
logfileprefix => "mainserver", # Logfileprefix
# net::server
server => undef, # attributes for Net::Server::PreFork
};
}
sub _Init
{
my $this = shift;
return unless $this->SUPER::_Init(@_);
return $this->_SetError("You have to specify at least the SASL mechs and the commands you want to run, to start the ARCv2 Server.")
unless $this->{connection_vars};
unless (defined $this->{server}->{host}) {
$this->Log(LOG_SIDE,"No host (listenaddress) specified, falling back to all addresses (0).");
lib/Arc/Server.pm view on Meta::CPAN
$this->{server}->{proto} = 'tcp';
$this->{server}->{listen} = SOMAXCONN;
$this->{server}->{child_communication} = undef,
}
## start the server
## This function is used by the user to start the server and enter the main accept-loop.
## Only by calling the C<Interrupt> function this call can be aborted.
##out> return true if everything worked fine, otherwise false is returned and C<IsError> should be checked.
##eg> $arc->Start();
sub Start
{
my $this = shift;
my $ct = $this->{connection_type};
eval "require $ct";
croak "Please \"use $ct\" before calling Start(): $@" if $@;
$this->run();
return 1;
}
# Net::Server::* hooks and overrides
sub process_request
{
my $this = shift;
my $arc = $this->{__arc};
# my $arc = new Arc::Connection::Server(
# %{$this->{connection_vars}},
# );
return $this->_SetError("No Arc::Connection::Server object was created.")
unless $arc;
$this->Log(LOG_USER,"Client connection from",$this->{server}->{client}->peerhost);
$arc->HandleClient($this->{server}->{client});
$arc->clean;
$this->Log(LOG_USER,"Client connection closed.");
}
sub write_to_log_hook
{
my ($this,$loglevel,$msg) = @_;
$msg =~ s/[\n\r]//g;
$this->Log(LOG_SIDE,$msg);
1;
}
sub child_init_hook
{
my $this = shift;
my $ct = $this->{connection_type};
$this->{__arc} = new $ct (
%{$this->{connection_vars}},
);
}
# deleting STDIN and STDOUT kills ARCv2, don't know if Net::Server does
# is right
sub post_accept
{
my $this = shift;
my $prop = $this->{server};
### keep track of the requests
$prop->{requests} ++;
}
1;
lib/Arc/Server.pod view on Meta::CPAN
B<Example:>
return $arc->Log(LOG_ERR,"Message");
=item new ( %hash, key => val, ... ) I<inherited from Arc>
B<Description>: Constructor.
Initializes the object and returns it blessed.
For all sub classes, please override C<_Init> to check the
parameter which are passed to the C<new> function. This
is necessary because you are not able to call the the new method of a
parent class, when having a class name (new $class::SUPER::new, does not work.).
B<Returns:> blessed object of the class
B<Example:>
lib/Arc/Server.pod view on Meta::CPAN
B<Description>: Init function (initializes class context)
Module dependent initialization, every subclass shall override it
and call the _Init of its SUPER class. This method is called by the new method of C<Arc>.
B<Returns:> true, if all passed values are in their definition scope, otherwise false
B<Example:>
see source code of any non-abstract sub class of Arc
=item _SetError ( ... (message) ) I<inherited from Arc>
B<Description>: SetError function.
This function prepends the error message (@_) to an existing error message (if any) and
logs the message with LOG_ERR facility.
Use this function for setting an error from class level. Users should use IsError
to get the message if a function failed.
scripts/PBConfig.pm view on Meta::CPAN
require Exporter;
use vars qw(@ISA @EXPORT_OK @config $fn $opt @EXPORT $usage);
@ISA = qw(Exporter);
@EXPORT = qw(@config $fn $opt opt_parse file_parse opt_help $usage); # symbols to export on request
# Configuration array, Filename to treat
$opt = {};
$usage = sub {};
sub opt_parse
{
my @go = ();
foreach (@config) {
my ($n,$c,$t);
$n = $_->[1] eq "b" ? $_->[0]."!" : $_->[0];
$c = $_->[1] ne "" && $_->[1] ne "b" ? "=" : "";
$t = $_->[1] eq "b" ? "" : $_->[1];
push @go, $n.$c.$t;
}
scripts/PBConfig.pm view on Meta::CPAN
);
&$usage() if $opt->{help};
# getting default values
foreach (@config) {
$opt->{$_->[0]} = $_->[2] unless defined $opt->{$_->[0]};
}
}
sub file_parse {
open(FS,"<$fn");
open(FD,">$fn.new");
my $c = 0;
my $ins;
while(my $l = <FS>) {
$ins = 0;
foreach (@config) {
if ($l =~ /^\$$_->[0]/) {
my ($v);
scripts/PBConfig.pm view on Meta::CPAN
if ($c != scalar @config) {
#if (1) {
die "Could not find all hooks for setting default values in $fn.";
} else {
unlink("$fn");
rename("$fn.new","$fn");
}
}
sub opt_help
{
foreach (@config) {
my ($n);
$n = $_->[1] eq "b" ? "(no-)".$_->[0] : $_->[0];
print " --".$n."\t".$_->[3]."\n";
}
}
1;
scripts/arcx view on Meta::CPAN
err("Could not connect to '$args{h}:$args{p}': ",$arc->IsError());
$retval = 1;
next;
}
verbout("Available SASL mechanisms return by the server: ",join(", ",@{$arc->{server_sasl_mechanisms}}));
last;
}
exit $retval;
sub showhelp
{
print <<EOT;
internal command for this client:
? for this help
\\q,^D quit
EOT
}
sub usage
{
my $msg = shift;
print STDERR <<EOT;
$msg
$0 [-h <hostname>] [-p <port>] [-l <loglevel]
[-L <logdestination] [-n] [-v] [-S <service>]
[-F -f <history>] [-u|-U <username>] [-a|-A <authname>]
[-w|-W <password>] [-s <mech>] [-t <timeout in sec>]
[-r <string>] [-V] [-C <conffile>] [command [command-arguments]]
scripts/arcx view on Meta::CPAN
-V display version information
$Arc::Copyright
$Arc::Contact
EOT
exit 1;
}
sub username
{
if (defined $args{U} && $args{U} ne "") {
return $args{U};
} elsif (defined $args{u}) {
print STDERR "Enter your username: "; return <STDIN>;
} else {
return $ENV{'USER'};
}
}
sub authname
{
if (defined $args{A} && $args{A} ne "") {
return $args{A};
} elsif (defined $args{a}) {
print STDERR "Enter your name for authorization: "; return <STDIN>;
} else {
return $ENV{'USER'};
}
}
sub password
{
if (defined $args{P} && $args{P} ne "") {
return $args{P};
} elsif (defined $args{p}) {
print STDERR "Enter your password: ";
ReadMode 2;
my $pw = <STDIN>;
ReadMode 0;
return $pw;
} else {
return $ENV{'USER'};
}
}
sub verbout
{
err("verbose:",@_) if $args{v};
}
sub err
{
print STDERR join(" ",@_),"\n";
1;
}
sub interrupt
{
my $sig = shift;
verbout("Received signal: $sig.");
$stop = 1;
undef;
}
sub addhistoryfile
{
unless ($args{F}) {
unless (open(FH,">>$args{f}")) {
$args{F} = 1;
err("Cannot write to history file: $args{f}. (",$!,")");
return;
}
print FH join(" ",@_),"\n";
close (FH);
}
scripts/arcxd view on Meta::CPAN
);
if (my $msg = $arc->IsError()) {
err($msg);
exit 1;
}
$arc->Start();
sub verbout
{
err("verbose:",@_) if $args{v};
}
sub err
{
print STDERR join(" ",@_),"\n";
1;
}
sub usage
{
my $msg = shift;
print STDERR <<EOT;
$msg
$0 -d <loglevel> -F <config file> -p <listenport> -v
-d <loglevel> loglevel (see man Arc) and do not fork into backgroup
-p <port> port the server shall listen on
-P <pid_file> PID file
-F <config file> specify the config file, where the server finds information
scripts/object.pl view on Meta::CPAN
showclass_members($base,0,0,"private");
%ready = ();
podout("head1","Class METHODS");
showclass_methods($base,0,0,"public");
showclass_methods($base,0,0,"protected");
showclass_methods($base,0,0,"private");
print "\n";
sub access_level
{
$_ = $_[0];
if (/^__/) {
return "private";
} elsif (/^_/) {
return "protected";
} else {
return "public";
}
}
sub issuperior
{
my ($type,$cname,$item,$acl) = @_;
my $text = "";
while ($cname = $iter{$cname}) {
if (eval '$'.$type.'{$cname}->{$acl}->{$item}') {
$ready{$item} = 1;
$text = "reimplemented from $cname";
last;
}
}
return $text;
}
sub showmembers
{
my $inh = shift;
my $cname = shift;
my $aclevel = shift;
my %ac = @_;
%ac = %{$ac{$aclevel}};
foreach (sort { uc($a) cmp uc($b) } keys %ac) {
# superior classes maybe have this method, we want to know which one
next if $ready{$_};
scripts/object.pl view on Meta::CPAN
if ($ac{$_}->{desc}) {
textout("B<Description>: ",$ac{$_}->{desc});
}
if ($ac{$_}->{value}) {
textout("B<Default value>: ",$ac{$_}->{value});
}
}
}
sub showmethods
{
my $inh = shift;
my $cname = shift;
my $aclevel = shift;
my %ac = @_;
%ac = %{$ac{$aclevel}};
foreach (sort { uc($a) cmp uc($b) } keys %ac) {
# superior classes maybe have this method, we want to know which one
next if $ready{$_};
my $inherited = issuperior("methods",$cname,$_,$aclevel);
scripts/object.pl view on Meta::CPAN
textout("B<Returns:> ",$ac{$_}->{doc}->{out});
}
if ($ac{$_}->{doc}->{eg}) {
textout("B<Example:>");
textout($ac{$_}->{doc}->{eg});
}
}
}
sub showclass_methods
{
my ($name,$inl,$inh,$acc) = @_;
podout("head3",uc("$acc methods")) unless $inh;
if ($methods{$name}->{$acc}) {
podout("over",2);
showmethods($inh ? "inherited from ".$name : "" ,$name,$acc,%{$methods{$name}});
podout("back");
}
if ($acc ne "private" && $iter{$name} ) {
foreach (split(/\s+/,$iter{$name})) {
showclass_methods($_,$inl+1,1,$acc);
}
}
}
sub showclass_members
{
my ($name,$inl,$inh,$acc) = @_;
podout("head3",uc("$acc members")) unless $inh;
if ($members{$name}->{$acc}) {
podout("over",2);
showmembers($inh ? "inherited from ".$name : "",$name,$acc,%{$members{$name}});
podout("back");
}
if ($acc ne "private" && $iter{$name} ) {
foreach (split(/\s+/,$iter{$name})) {
showclass_members($_,$inl+1,1,$acc);
}
}
}
sub podout
{
my $h = shift;
print "\n=",$h," ",@_ ? join("",@_):"","\n";
}
sub textout
{
print "\n",@_,"\n";
}
sub verbout
{
# if ($args{v})
# print STDERR join(" ",@_),"\n";
}
wait();
} else {
ok(0);
}
ok(1);
exit 0;
sub checkpass
{
my ($user,$vpass) = @_;
return ($vpass eq $pass);
}
sub getsecret
{
return $pass;
}
( run in 0.490 second using v1.01-cache-2.11-cpan-a5abf4f5562 )