AFS
view release on metacpan or search on metacpan
Makefile.PL view on Meta::CPAN
WriteMakefile(
'NAME' => 'AFS',
'VERSION' => $VERSION,
($] >= 5.005 ?
('AUTHOR' => 'Norbert E Gruener <nog@MPA-Garching.MPG.de>',
'ABSTRACT' => 'Perl interface to AFS programming APIs',
) : () ),
'realclean' => {FILES => "Makefile.bak lib" },
);
sub MY::postamble {
'
html:
cp ./pod/v2/Makefile.inp lib/Makefile
cp ./pod/v2/zpod2html lib/
cd lib && $(MAKE) html
';
}
examples/v2/bos/constructor view on Meta::CPAN
$server = shift;
$cellname = shift;
if ($cellname) { $bos = AFS::BOS->new($server, 0, 0, $cellname); }
else { $bos = AFS::BOS->new($server); }
if ($AFS::CODE) { print "AFS::CODE = $AFS::CODE\n"; }
else { print "OK \n"; }
test_it($bos);
sub test_it {
my $self = shift;
$self->DESTROY;
}
examples/v2/bos/listkeys view on Meta::CPAN
}
}
}
chomp($lastmod = strftime('%d %b %R %Y', localtime($lastmod)));
print "Keys last changed on $lastmod\n";
print "All done.\n";
$bos->DESTROY;
sub print_key {
my $key = shift;
print "key is: ";
my (@val) = unpack("C*", $key);
foreach (@val) { printf("\\%o", $_); }
print "\n";
}
examples/v2/kas/constructor view on Meta::CPAN
use AFS::KTC_TOKEN;
die "Usage: $0 \n" if $#ARGV != -1;
my $kas = AFS::KAS->AuthServerConn(AFS::KTC_TOKEN->nulltoken, &AFS::KA_MAINTENANCE_SERVICE);
if ($AFS::CODE) { print "Error Code: $AFS::CODE\n"; }
else { print "OK \n"; }
test_it($kas);
sub test_it {
my $self = shift;
$self->DESTROY;
}
examples/v2/pts/constructor view on Meta::CPAN
$sec = shift unless $sec;
$cell = shift unless $cell;
$pts = AFS::PTS->new($sec, $cell);
if ($AFS::CODE) { print "Error Code: $AFS::CODE\n"; }
else { print "OK \n"; }
test_it($pts);
sub test_it {
my $self = shift;
$self->DESTROY;
}
examples/v2/vldb/constructor view on Meta::CPAN
die "Usage: $0 [verbose]\n" if $#ARGV > 0;
$verbose = shift // 0;
$vldb = AFS::VLDB->new($verbose);
if ($AFS::CODE) { print "AFS::CODE = $AFS::CODE\n"; }
else { print "OK \n"; }
test_it($vldb);
sub test_it {
my $self = shift;
$self->DESTROY;
}
examples/v2/vldb/listvldb view on Meta::CPAN
$vldb = AFS::VLDB->new;
$AFS::CODE and print "AFS::CODE = $AFS::CODE\n";
my $vldblist = $vldb->listvldb($serv, $part, $lock);
$AFS::CODE and print "AFS::CODE = $AFS::CODE\n";
$Debugging && print_debug($vldblist);
print_vldblist($vldblist);
sub print_vldblist {
my ($vldblist) = @_;
foreach my $val (keys %$vldblist) {
print "Key: $val\n";
foreach my $ent (keys %{$vldblist->{$val}}) {
if ($ent eq 'server') {
my $i = 1;
foreach my $srv (@{$vldblist->{$val}->{$ent}}) {
print "\tServer number $i:\n";
$i++;
examples/v2/vldb/listvldb view on Meta::CPAN
}
}
}
else {
print "\tKey: $ent, Value: $vldblist->{$val}->{$ent}\n";
}
}
}
}
sub print_debug {
my ($vldblist) = @_;
foreach my $val (keys %$vldblist) {
print "$val:\n";
foreach my $ent (keys %{$vldblist->{$val}}) {
if ($ent eq 'server') {
printf "\t%10s \n", $ent;
foreach my $srv (@{$vldblist->{$val}->{$ent}}) {
foreach my $s (keys %{$srv}) {
printf "\t\t%12s: %s\n", $s, $srv->{$s};
examples/v2/vldb/listvldbentry view on Meta::CPAN
$vol = shift;
$vldb = AFS::VLDB->new;
$AFS::CODE and print "AFS::CODE = $AFS::CODE\n";
my $vldblist = $vldb->listvldbentry($vol);
$AFS::CODE and print "AFS::CODE = $AFS::CODE\n";
print_vldblist($vldblist);
sub print_vldblist {
my ($vldblist) = @_;
foreach my $val (keys %$vldblist) {
print "Key: $val\n";
foreach my $ent (keys %{$vldblist->{$val}}) {
if ($ent eq 'server') {
my $i = 1;
foreach my $srv (@{$vldblist->{$val}->{$ent}}) {
print "\tServer number $i:\n";
$i++;
examples/v2/vos/constructor view on Meta::CPAN
die "Usage: $0 [verbose]\n" if $#ARGV > 0;
$verbose = shift // 0;
$vos = AFS::VOS->new($verbose);
if ($AFS::CODE) { print "AFS::CODE = $AFS::CODE\n"; }
else { print "OK \n"; }
test_it($vos);
sub test_it {
my $self = shift;
$self->DESTROY;
}
examples/v2/vos/examine view on Meta::CPAN
$vldb = AFS::VLDB->new;
$AFS::CODE and print "AFS::CODE = $AFS::CODE\n";
$vldblist = $vldb->listvldbentry($volume);
$AFS::CODE and print "AFS::CODE = $AFS::CODE\n";
print_vol($vollist);
print_vldb($vldblist);
sub print_vol {
my $vollist = shift;
print "$vollist->{name} \t$vollist->{volid} $vollist->{type} \t $vollist->{size} K $vollist->{inUse}\n";
print "\t$vollist->{server} $vollist->{partition}\n";
print "\tRWrite $vollist->{parentID} ROnly $vollist->{cloneID} Backup $vollist->{backupID}\n";
print "\tMaxQuota $vollist->{maxquota} K\n";
print "\tCreation ", ctime($vollist->{creationDate}), "\n";
print "\tCopy ", ctime($vollist->{copyDate}), "\n";
print "\tBackup ", ctime($vollist->{backupDate}), "\n";
print "\tLast Update ", ctime($vollist->{updateDate}), "\n";
print "\t$vollist->{dayUse} accesses in the past day (i.e., vnode references)\n";
}
sub print_vldb {
my ($vldblist) = @_;
print "\tRWrite: $vldblist->{$volume}->{RWrite} \n";
print "\tnumber of sites -> $vldblist->{$volume}->{nServers}\n";
foreach my $srv (@{$vldblist->{$volume}->{server}}) {
print "\t\tserver $srv->{name} partition $srv->{partition} $srv->{type} site\n";
}
}
examples/v2/vos/listvol view on Meta::CPAN
my $partlist = $vos->listvol($server, $part, $fast, $extend);
$AFS::CODE and print "AFS::CODE = $AFS::CODE\n" and die;
if ($fast) { print_fast($partlist); }
elsif ($extend) { print_ext($partlist); }
elsif ($Debugging) { print_debug($partlist); }
elsif ($long) { print_long($partlist); }
else { print_default($partlist); }
sub print_fast {
my $partlist = shift;
my $totvol = 0;
foreach my $part (sort keys %$partlist) {
foreach my $vol (sort keys %{$partlist->{$part}}) {
if ($vol =~ /totalBusy/) { next; }
elsif ($vol =~ /totalNotOK/) { next; }
$totvol++;
if ($vol !~ /total/) {
foreach my $key (sort keys %{$partlist->{$part}->{$vol}}) {
print "$partlist->{$part}->{$vol}->{$key}\n";
}
}
}
}
print "Total number of volumes on server $server partition /vicep$part: $totvol \n";
}
sub print_ext {
my $partlist = shift;
foreach my $part (sort keys %$partlist) {
print "Partition $part:\n";
foreach my $vol (sort keys %{$partlist->{$part}}) {
if ($vol !~ /total/) {
if ($vol =~ /volume_busy/) {
print "\t**** Volume $partlist->{$part}->{$vol}->{volid} is busy **** \n";
}
elsif ($vol =~ /volume_notok/) {
examples/v2/vos/listvol view on Meta::CPAN
}
print "\n";
}
}
print "\ttotalOK: $partlist->{$part}->{' totalOK'}\n";
print "\ttotalBusy: $partlist->{$part}->{' totalBusy'}\n";
print "\ttotalNotOK: $partlist->{$part}->{' totalNotOK'}\n";
}
}
sub print_long {
my $partlist = shift;
foreach my $part (sort keys %$partlist) {
print "$part:\n";
foreach my $vol (sort keys %{$partlist->{$part}}) {
if ($vol !~ /total/) {
if ($vol =~ /volume_busy/) {
print "\t**** Volume $partlist->{$part}->{$vol}->{'volid'} is busy **** \n";
}
elsif ($vol =~ /volume_notok/) {
examples/v2/vos/listvol view on Meta::CPAN
}
print "\n";
}
}
print "\ttotalOK: $partlist->{$part}->{' totalOK'}\n";
print "\ttotalBusy: $partlist->{$part}->{' totalBusy'}\n";
print "\ttotalNotOK: $partlist->{$part}->{' totalNotOK'}\n";
}
}
sub print_default {
my $partlist = shift;
my $totvol = 0;
foreach my $part (sort keys %$partlist) {
print "List of volumes on server $server Partition $part: \n";
foreach my $vol (sort keys %{$partlist->{$part}}) {
if ($vol =~ /totalOK/) { next; }
elsif ($vol =~ /totalBusy/) { next; }
elsif ($vol =~ /totalNotOK/) { next; }
elsif ($vol =~ /volume_busy/) {
examples/v2/vos/listvol view on Meta::CPAN
# foreach (keys %{$partlist->{$part}->{$vol}}) {
# print "\t\tKey: $_, Value: $partlist->{$part}->{$vol}->{$_}\n";
# }
}
print "\nTotal volumes onLine $partlist->{$part}->{' totalOK'} ;";
print "\tTotal volumes offLine $partlist->{$part}->{' totalNotOK'} ;";
print "\tTotal busy $partlist->{$part}->{' totalBusy'} \n";
}
}
sub print_debug {
my $partlist = shift;
foreach my $part (sort keys %$partlist) {
print "$part:\n";
foreach my $vol (sort keys %{$partlist->{$part}}) {
if ($vol =~ /total/) {
print "\t$vol: $partlist->{$part}->{$vol}\n";
}
else {
print "\t$vol:\n";
examples/v2/vos/listvolume view on Meta::CPAN
$vos = AFS::VOS->new;
$AFS::CODE and print "AFS::CODE = $AFS::CODE\n";
my $vollist = $vos->listvolume($volume);
$AFS::CODE and print "AFS::CODE = $AFS::CODE\n";
$Debugging && print_debug($vollist) && exit;
print_volume($vollist);
sub print_volume {
my $vollist = shift;
print "$vollist->{name} \t$vollist->{parentID} $vollist->{type} \t $vollist->{size} K $vollist->{inUse}\n";
print "\t$vollist->{server} $vollist->{partition}\n";
print "\tRWrite $vollist->{parentID} ROnly $vollist->{cloneID} Backup $vollist->{backupID}\n";
print "\tMaxQuota $vollist->{maxquota} K\n";
print "\tCreation ", ctime($vollist->{creationDate}), "\n";
print "\tCopy ", ctime($vollist->{copyDate}), "\n";
print "\tBackup ", ctime($vollist->{backupDate}), "\n";
print "\tLast Access ", ctime($vollist->{accessDate}), "\n";
print "\tLast Update ", ctime($vollist->{updateDate}), "\n";
print "\t$vollist->{dayUse} accesses in the past day (i.e., vnode references)\n";
}
sub print_debug {
my $vollist = shift;
foreach my $key (sort keys %{$vollist}) {
printf("%20s %s\n", $key, $vollist->{$key});
}
print "\n\n";
}
examples/v2/vos/partinfo view on Meta::CPAN
$AFS::CODE and print "AFS::CODE = $AFS::CODE\n";
$Debugging && print_debug($partinfo) && exit;
foreach my $part (keys %$partinfo) {
print "Free space on partition $part: ";
print "$partinfo->{$part}->{free} K blocks out of total $partinfo->{$part}->{minFree}\n";
}
sub print_debug {
my $partinfo = shift;
foreach my $key1 (sort keys %{$partinfo}) {
foreach my $key2 (sort keys %{$partinfo->{$key1}}) {
printf("%10s %10s %s\n", $key1, $key2, $partinfo->{$key1}->{$key2});
}
}
print "\n\n";
}
src/ACL/ACL.pm view on Meta::CPAN
# under the same terms as Perl itself.
#------------------------------------------------------------------------------
use AFS ();
use vars qw(@ISA $VERSION);
@ISA = qw(AFS);
$VERSION = 'v2.6.4';
sub new {
my ($this, $class);
# this whole construct is to please the old version from Roland
if ($_[0] =~ /AFS::ACL/) {
$this = shift;
$class = ref($this) || $this;
}
else {
$class = 'AFS::ACL';
}
my $pos_rights = shift;
my $neg_rights = shift;
my $self = [{}, {}];
if (defined $pos_rights) { %{$self->[0]} = %$pos_rights; }
if (defined $neg_rights) { %{$self->[1]} = %$neg_rights; }
bless $self, $class;
}
sub copy {
my $self = shift;
my $class = ref($self) || $self;
my $new = [{}, {}];
%{$new->[0]} = %{$self->[0]};
%{$new->[1]} = %{$self->[1]};
bless $new, $class;
}
sub apply {
my $self = shift;
my $path = shift;
my $follow = shift;
$follow = 1 unless defined $follow;
AFS::setacl($path, $self, $follow);
}
sub retrieve {
my $class = shift;
my $path = shift;
my $follow = shift;
$follow = 1 unless defined $follow;
AFS::_getacl($path, $follow);
}
sub modifyacl {
my $self = shift;
my $path = shift;
my $follow = shift;
my $newacl;
$follow = 1 unless defined $follow;
if ($newacl = AFS::_getacl($path, $follow)) {
$newacl->add($self);
AFS::setacl($path, $newacl, $follow);
}
else { return 0; }
}
sub copyacl {
my $class = shift;
my $from = shift;
my $to = shift;
my $follow = shift;
my $acl;
$follow = 1 unless defined $follow;
if ($acl = AFS::_getacl($from, $follow)) { AFS::setacl($to, $acl, $follow); }
else { return 0; }
}
sub cleanacl {
my $class = shift;
my $path = shift;
my $follow = shift;
my $acl;
$follow = 1 unless defined $follow;
if (! defined ($acl = AFS::_getacl($path, $follow))) { return 0; }
if ($acl->is_clean) { return 1; }
AFS::setacl($path, $acl, $follow);
}
sub crights {
my $class = shift;
AFS::crights(@_);
}
sub ascii2rights {
my $class = shift;
AFS::ascii2rights(@_);
}
sub rights2ascii {
my $class = shift;
AFS::rights2ascii(@_);
}
# old form DEPRECATED !!!!
sub addacl {
my $self = shift;
my $macl = shift;
foreach my $key ($macl->keys) { $self->set($key, $macl->get($key)); }
foreach my $key ($macl->nkeys) { $self->nset($key, $macl->nget($key)); }
return $self;
}
sub add {
my $self = shift;
my $acl = shift;
foreach my $user ($acl->get_users) { $self->set($user, $acl->get_rights($user)); }
foreach my $user ($acl->nget_users) { $self->nset($user, $acl->nget_rights($user)); }
return $self;
}
sub is_clean {
my $self = shift;
foreach ($self->get_users, $self->nget_users) { return 0 if (m/^-?\d+$/); }
return 1;
}
# comment Roland Schemers: I hope I don't have to debug these :-)
sub empty { $_[0] = bless [ {},{} ]; }
sub get_users { CORE::keys %{$_[0]->[0]}; }
sub length { int(CORE::keys %{$_[0]->[0]}); }
sub get_rights { ${$_[0]->[0]}{$_[1]}; }
sub exists { CORE::exists ${$_[0]->[0]}{$_[1]}; }
sub set { ${$_[0]->[0]}{$_[1]} = $_[2]; }
sub remove { delete ${$_[0]->[0]}{$_[1]}; }
sub clear { $_[0]->[0] = {}; }
sub keys { CORE::keys %{$_[0]->[0]}; } # old form: DEPRECATED !!!!
sub get { ${$_[0]->[0]}{$_[1]}; } # old form: DEPRECATED !!!!
sub del { delete ${$_[0]->[0]}{$_[1]}; } # old form: DEPRECATED !!!!
# comment Roland Schemers: same for negative entries
sub nget_users { CORE::keys %{$_[0]->[1]}; }
sub nlength { int(CORE::keys %{$_[0]->[1]}); }
sub nget_rights { ${$_[0]->[1]}{$_[1]}; }
sub nexists { CORE::exists ${$_[0]->[1]}{$_[1]}; }
sub nset { ${$_[0]->[1]}{$_[1]} = $_[2]; }
sub nremove { delete ${$_[0]->[1]}{$_[1]}; }
sub nclear { $_[0]->[1] = {}; }
sub nkeys { CORE::keys %{$_[0]->[1]}; } # old form: DEPRECATED !!!!
sub nget { ${$_[0]->[1]}{$_[1]}; } # old form: DEPRECATED !!!!
sub ndel { delete ${$_[0]->[1]}{$_[1]}; } # old form: DEPRECATED !!!!
1;
@EXPORT_OK = qw(
raise_exception
constant
convert_numeric_names
error_message
);
@ALL = (@EXPORT, @EXPORT_OK);
# convenience functions
#sub newacl { use AFS::ACL; AFS::ACL->new(@_); }
sub newacl { require AFS::ACL; AFS::ACL->import; AFS::ACL->new(@_); }
sub newpts { AFS::PTS->_new(@_); }
sub newprincipal { AFS::KTC_PRINCIPAL->_new(@_); }
sub ktc_principal { AFS::KTC_PRINCIPAL->_new(@_); }
sub ka_LocalCell { return &localcell; }
sub ka_ExpandCell { expandcell($_[0]); }
sub ka_CellToRealm { uc(expandcell($_[0])); }
sub afsok { $AFS::CODE == 0; }
sub checkafs { die "$_[0]: $AFS::CODE" if $AFS::CODE; }
sub get_server_version {
my $server = shift;
my $hostname = shift;
my $verbose = shift;
my %port = (
'fs' => 7000,
'cm' => 7001,
'pts' => 7002,
'vls' => 7003,
'kas' => 7004,
if (! defined $port{$server}) { die "Server $server unknown ...\n"; }
$hostname = 'localhost' unless defined $hostname;
$verbose = 0 unless defined $verbose;
AFS::_get_server_version($port{$server}, $hostname, $verbose);
}
# acl helpers...
sub getacl { require AFS::ACL; AFS::ACL->import; AFS::_getacl(@_); }
sub modifyacl {
my($path, $macl) = @_;
my($acl);
if ($acl = getacl($path)) {
$acl->addacl($macl);
return setacl($path, $acl);
}
else { return 0; }
}
sub copyacl {
my($from, $to, $follow) = @_;
my($acl);
$follow = 1 unless defined $follow;
if ($acl = _getacl($from, $follow)) { return setacl($to, $acl, $follow); }
else { return 0; }
}
sub cleanacl {
my($path, $follow) = @_;
my($acl);
$follow = 1 unless defined $follow;
if ($acl = _getacl($path, $follow)) { return setacl($path, $acl, $follow); }
else { return 0; }
}
# package AFS::PTS_SERVER;
# sub new { AFS::PTS->_new(@_); }
use AFS::KTC_PRINCIPAL;
# package AFS::KTC_PRINCIPAL;
# sub new { AFS::KTC_PRINCIPAL->_new(@_); }
use AFS::KAS;
# *** CAUTION ***
# these functions are now stored in AFS::KAS.pm !!!
#package AFS::KA_AUTHSERVER;
# package AFS::KAS;
# sub getentry { $_[0]->KAM_GetEntry($_[1],$_[2]); }
# sub debug { $_[0]->KAM_Debug(&AFS::KAMAJORVERSION); }
# sub getstats { $_[0]->KAM_GetStats(&AFS::KAMAJORVERSION); }
# sub randomkey { $_[0]->KAM_GetRandomKey; }
# sub create { $_[0]->KAM_CreateUser($_[1],$_[2],$_[3]); }
# sub setpassword { $_[0]->KAM_SetPassword($_[1],$_[2],$_[3],$_[4]); }
# sub delete { $_[0]->KAM_DeleteUser($_[1],$_[2]); }
# sub listentry { $_[0]->KAM_ListEntry($_[1],$_[2],$_[3]); }
# sub setfields { $_[0]->KAM_SetFields($_[1],$_[2],$_[3],$_[4],$_[5],$_[6],$_[7],$_[8]); }
package AFS;
sub AUTOLOAD {
# This AUTOLOAD is used to 'autoload' constants from the constant()
# XS function. If a constant is not found then control is passed
# to the AUTOLOAD in AutoLoader.
# taken from perl v5.005_02 for backward compatibility
my $constname;
($constname = $AUTOLOAD) =~ s/.*:://;
croak "& not defined" if $constname eq 'constant';
my $val = constant($constname, @_ ? $_[0] : 0);
goto &AutoLoader::AUTOLOAD;
}
else {
croak "Your vendor has not defined AFS macro $constname";
}
}
{
no strict 'refs';
# Fixed between 5.005_53 and 5.005_61
if ($] >= 5.00561) {
*$AUTOLOAD = sub () { $val };
}
else {
*$AUTOLOAD = sub { $val };
}
}
goto &$AUTOLOAD;
}
END {
AFS::_finalize();
}
bootstrap AFS;
src/BOS/BOS.pm view on Meta::CPAN
#------------------------------------------------------------------------------
use Carp;
use AFS ();
use vars qw(@ISA $VERSION);
@ISA = qw(AFS);
$VERSION = 'v2.6.4';
sub DESTROY {
my (undef, undef, undef, $subroutine) = caller(1);
if (! defined $subroutine or $subroutine !~ /eval/) { undef $_[0]; } # self->DESTROY
else { AFS::BOS::_DESTROY($_[0]); } # undef self
}
sub create {
my $self = shift;
my $process = shift;
my $type = shift;
my $command = shift;
my $notifier = shift;
if (! defined $process ||
! defined $type ||
! defined $command) {
carp "AFS::BOS->create: incomplete arguements specified ...\n";
src/BOS/BOS.pm view on Meta::CPAN
$commands[0] = $command;
if ($notifier) { $self->_create($process, $type, \@commands, $notifier); }
else { $self->_create($process, $type, \@commands); }
}
else {
carp "AFS::BOS->create: not a valid COMMAND input ...\n";
return 0;
}
}
sub restart {
my $self = shift;
if ($#_ == 0 and ref($_[0]) eq 'ARRAY') { # SERVER is array ref
$self->_restart(0, 0, @_);
}
elsif ($#_ == 0 and ref($_[0]) eq '') { # SERVER is scalar
my @server;
$server[0] = shift;
$self->_restart(0, 0, \@server);
}
else {
carp "AFS::BOS->restart: not a valid input ...\n";
return undef;
}
}
sub restart_all {
my $self = shift;
$self->_restart(0, 1);
}
sub restart_bos {
my $self = shift;
$self->_restart(1);
}
sub start {
my $self = shift;
if ($#_ == 0 and ref($_[0]) eq 'ARRAY') { # SERVER is array ref
$self->_start(@_);
}
elsif ($#_ == 0 and ref($_[0]) eq '') { # SERVER is scalar
my @server;
$server[0] = shift;
$self->_start(\@server);
}
else {
carp "AFS::BOS->start: not a valid input ...\n";
return undef;
}
}
sub startup {
my $self = shift;
if ($#_ == -1) { # no input given
$self->_startup();
}
elsif ($#_ == 0 and ref($_[0]) eq 'ARRAY') { # SERVER is array ref
$self->_startup(@_);
}
elsif ($#_ == 0 and ref($_[0]) eq '') { # SERVER is scalar
my @server;
$server[0] = shift;
$self->_startup(\@server);
}
else {
carp "AFS::BOS->startup: not a valid input ...\n";
return undef;
}
}
sub status {
my $self = shift;
if ($#_ > 0 and ! defined $_[1]) { $_[1] = ''; } # INSTANCE is not defined
if (ref($_[1]) eq 'ARRAY' or $#_ <= 0) { # INSTANCE is array ref
$self->_status(@_);
}
elsif ($_[1] eq '') { # INSTANCE is not defined
$self->_status($_[0]);
}
src/BOS/BOS.pm view on Meta::CPAN
$server[0] = $args[1];
$args[1] = \@server;
$self->_status(@args);
}
else {
carp "AFS::BOS->status: not a valid input ...\n";
return undef;
}
}
sub stop {
my $self = shift;
if ($#_ == -1 or ($#_ > -1 and ! defined $_[0])) {
carp "AFS::BOS->stop: not a valid input ...\n";
return undef;
}
if (ref($_[0]) eq 'ARRAY') { # SERVER is array ref
$self->_stop(@_);
}
src/BOS/BOS.pm view on Meta::CPAN
my @server;
$server[0] = shift;
$self->_stop(\@server, @_);
}
else {
carp "AFS::BOS->stop: not a valid input ...\n";
return undef;
}
}
sub shutdown {
my $self = shift;
if ($#_ == 1 and ref($_[0]) eq 'ARRAY') { # SERVER is array ref
$self->_shutdown(@_);
}
elsif ($#_ == 1 and ref($_[0]) eq '') { # SERVER is scalar
my @server;
$server[0] = shift;
$self->_shutdown(\@server, @_);
}
src/BOS/t/BOS.t view on Meta::CPAN
can_ok('AFS::BOS', qw(setauth));
can_ok('AFS::BOS', qw(setrestricted));
can_ok('AFS::BOS', qw(shutdown));
can_ok('AFS::BOS', qw(start));
can_ok('AFS::BOS', qw(startup));
can_ok('AFS::BOS', qw(stop));
$bos->DESTROY;
ok(! defined $bos, 'bos->DESTROY');
sub leak_test {
my $count = 0;
my $verb = 1;
while(1) {
$count++;
my $bos = AFS::BOS->new($verb);
$bos->DESTROY();
if ($count == 1210) { last; }
}
return $count;
}
src/KAS/KAS.pm view on Meta::CPAN
use AFS ();
use vars qw(@ISA $VERSION);
@ISA = qw(AFS);
$VERSION = 'v2.6.4';
# not suported anymore
# please use the functions from AFS::Cell !!!
#
# sub LocalCell {
# my $class = shift;
# AFS::localcell;
# }
# sub ExpandCell {
# my $class = shift;
# AFS::expandcell(@_);
# }
# sub CellToRealm {
# my $class = shift;
# uc(AFS::expandcell(@_));
# }
sub DESTROY {
my (undef, undef, undef, $subroutine) = caller(1);
if (! defined $subroutine or $subroutine !~ /eval/) { undef $_[0]; } # self->DESTROY
else { AFS::KAS::_DESTROY($_[0]); } # undef self
}
sub AuthServerConn {
my $class = shift;
AFS::ka_AuthServerConn(@_);
}
sub SingleServerConn {
my $class = shift;
AFS::ka_SingleServerConn(@_)
}
sub ChangePassword {
my $self = shift;
$self->ka_ChangePassword(@_)
}
sub Authenticate {
my $self = shift;
$self->ka_Authenticate(@_);
}
sub GetToken {
my $self = shift;
$self->ka_GetToken(@_)
}
# *** CAUTION ***
# these functions are redundant, they are also stored in AFS.pm !!!
sub getentry { $_[0]->KAM_GetEntry($_[1],$_[2]); }
sub debug { $_[0]->KAM_Debug(&AFS::KAMAJORVERSION); }
sub getstats { $_[0]->KAM_GetStats(&AFS::KAMAJORVERSION); }
sub randomkey { $_[0]->KAM_GetRandomKey; }
sub create { $_[0]->KAM_CreateUser($_[1],$_[2],$_[3]); }
sub setpassword { $_[0]->KAM_SetPassword($_[1],$_[2],$_[3],$_[4]); }
sub delete { $_[0]->KAM_DeleteUser($_[1],$_[2]); }
sub listentry { $_[0]->KAM_ListEntry($_[1],$_[2],$_[3]); }
sub setfields { $_[0]->KAM_SetFields($_[1],$_[2],$_[3],$_[4],$_[5],$_[6],$_[7]); }
1;
src/KTC_EKEY/KTC_EKEY.pm view on Meta::CPAN
# under the same terms as Perl itself.
#------------------------------------------------------------------------------
use AFS ();
use vars qw(@ISA $VERSION);
@ISA = qw(AFS);
$VERSION = 'v2.6.4';
sub UserReadPassword {
my $class = shift;
AFS::ka_UserReadPassword(@_);
}
sub ReadPassword {
my $class = shift;
AFS::ka_ReadPassword(@_);
}
sub StringToKey {
my $class = shift;
AFS::ka_StringToKey(@_);
}
sub des_string_to_key {
my $class = shift;
AFS::ka_des_string_to_key(@_);
}
# struct ktc_encryptionKey {
# char data[8];
# };
src/KTC_PRINCIPAL/KTC_PRINCIPAL.pm view on Meta::CPAN
# under the same terms as Perl itself.
#------------------------------------------------------------------------------
use AFS ();
use vars qw(@ISA $VERSION);
@ISA = qw(AFS);
$VERSION = 'v2.6.4';
sub ListTokens {
my $class = shift;
AFS::ktc_ListTokens(@_);
}
sub ParseLoginName {
my $class = shift;
AFS::ka_ParseLoginName(@_);
}
sub new {
# this whole construct is to please the old version from Roland
if ($_[0] =~ /AFS::KTC_PRINCIPAL/) { my $class = shift; }
my $name = shift;
my $inst = shift;
my $cell = shift;
my @args = ();
push @args, $name if defined $name;
push @args, $inst if defined $inst;
push @args, $cell if defined $cell;
src/KTC_TOKEN/KTC_TOKEN.pm view on Meta::CPAN
# under the same terms as Perl itself.
#------------------------------------------------------------------------------
use AFS ();
use vars qw(@ISA $VERSION);
@ISA = qw(AFS);
$VERSION = 'v2.6.4';
sub nulltoken {
my $class = shift;
AFS::ka_nulltoken;
}
sub GetAdminToken {
my $class = shift;
AFS::ka_GetAdminToken(@_);
}
sub GetAuthToken {
my $class = shift;
AFS::ka_GetAuthToken(@_);
}
sub GetServerToken {
my $class = shift;
AFS::ka_GetServerToken(@_);
}
sub GetToken {
my $class = shift;
AFS::ktc_GetToken(@_);
}
sub FromString {
my $class = shift;
AFS::ktc_FromString(@_);
}
sub SetToken {
my $class = shift;
AFS::ktc_SetToken(@_);
}
sub UserAuthenticateGeneral {
my $class = shift;
AFS::ka_UserAthenticateGeneral(@_);
}
sub ForgetAllTokens {
my $class = shift;
AFS::ktc_ForgetAllTokens;
}
# struct ktc_token {
# afs_int32 startTime;
# afs_int32 endTime;
# struct ktc_encryptionKey sessionKey;
src/PTS/PTS.pm view on Meta::CPAN
# under the same terms as Perl itself.
#------------------------------------------------------------------------------
use AFS ();
use vars qw(@ISA $VERSION);
@ISA = qw(AFS);
$VERSION = 'v2.6.4';
sub new {
# this whole construct is to please the old version from Roland
if ($_[0] =~ /AFS::PTS/) { my $class = shift; }
my $sec = shift;
my $cell = shift;
my @args = ();
push @args, $sec if defined $sec;
push @args, $cell if defined $cell;
AFS::PTS::_new('AFS::PTS', @args);
}
sub DESTROY {
my (undef, undef, undef, $subroutine) = caller(1);
if (! defined $subroutine or $subroutine !~ /eval/) { undef $_[0]; } # self->DESTROY
else { AFS::PTS::_DESTROY($_[0]); } # undef self
}
sub ascii2ptsaccess {
my $class = shift;
AFS::ascii2ptsaccess(@_);
}
sub ptsaccess2ascii {
my $class = shift;
AFS::ptsaccess2ascii(@_);
}
sub convert_numeric_names {
my $class = shift;
AFS::convert_numeric_names(@_);
}
1;
src/PTS/t/PTS.t view on Meta::CPAN
can_ok('AFS::PTS', qw(PR_SetFieldsEntry));
can_ok('AFS::PTS', qw(PR_SetMax));
can_ok('AFS::PTS', qw(PR_WhereIsIt));
$pts->DESTROY;
ok(! defined $pts, 'pts->DESTROY');
sub leak_test {
my $cell = shift;
my $count = 0;
my $sec = 1;
while(1) {
$count++;
my $pts = AFS::PTS->new($sec, $cell);
$pts->DESTROY();
if ($count == 1210) { last; }
}
src/VLDB/VLDB.pm view on Meta::CPAN
#------------------------------------------------------------------------------
use Carp;
use AFS ();
use vars qw(@ISA $VERSION);
@ISA = qw(AFS);
$VERSION = 'v2.6.4';
sub DESTROY {
my (undef, undef, undef, $subroutine) = caller(1);
if (! defined $subroutine or $subroutine !~ /eval/) { undef $_[0]; } # self->DESTROY
else { AFS::VLDB::_DESTROY($_[0]); } # undef self
}
sub delentry {
my $self = shift;
my $volume = shift;
my $noexec = shift;
$noexec = 0 unless $noexec;
if (! defined $volume) {
carp "AFS::VLDB->delentry: no VOLUME specified ...\n";
return (undef, undef);
}
src/VLDB/VLDB.pm view on Meta::CPAN
my @volumes;
$volumes[0] = $volume;
$self->_delentry(\@volumes, '', '', '', $noexec);
}
else {
carp "AFS::VLDB->delentry: not a valid input ...\n";
return (undef, undef);
}
}
sub delgroups {
my $self = shift;
my $prefix = shift;
my $server = shift;
my $part = shift;
my $noexec = shift;
$noexec = 0 unless $noexec;
$self->_delentry('', $prefix, $server, $part, $noexec);
}
sub listvldb {
my $self = shift;
$self->_listvldb('', @_);
}
sub listvldbentry {
my $self = shift;
$self->_listvldb($_[0]);
}
sub removeaddr {
my $self = shift;
my $ip_addr = shift;
$self->_changeaddr($ip_addr, '', 1);
}
sub syncvldb {
my $self = shift;
$self->_syncvldb(@_);
}
sub syncvldbentry {
my $self = shift;
$self->_syncvldb('', '', $_[0]);
}
1;
src/VLDB/t/VLDB.t view on Meta::CPAN
ok($ok, 'vldb->syncvldbentry(no_vol)');
$vldb->removeaddr('');
like($AFS::CODE, qr/invalid host address/, 'vldb->removeaddr(no arguments)');
$vldb->removeaddr('127.0.0.1');
like($AFS::CODE, qr/no such entry|Could not remove server/, 'vldb->removeaddr(invalid IP)');
$vldb->DESTROY;
ok(! defined $vldb, 'vldb->DESTROY');
sub leak_test {
my $cell = shift;
my $count = 0;
my $verb = 1;
while(1) {
$count++;
my $vldb = AFS::VLDB->new($verb);
$vldb->DESTROY();
if ($count == 1210) { last; }
}
src/VOS/VOS.pm view on Meta::CPAN
use Carp;
use AFS ();
use Scalar::Util qw(looks_like_number);
use vars qw(@ISA $VERSION);
@ISA = qw(AFS);
$VERSION = 'v2.6.4';
sub DESTROY {
my (undef, undef, undef, $subroutine) = caller(1);
if (! defined $subroutine or $subroutine !~ /eval/) { undef $_[0]; } # self->DESTROY
else { AFS::VOS::_DESTROY($_[0]); } # undef self
}
sub setquota {
my $self = shift;
my $volume = shift;
my $quota = shift || 0;
my $clear = shift || 0;
if (defined $quota and !looks_like_number($quota)) { warn "VOS::setquota: QUOTA is not an INTEGER ...\n"; return 0; }
else { $quota = int($quota); }
if (defined $clear and !looks_like_number($clear)) { warn "VOS::setquota: CLEAR is not an INTEGER ...\n"; return 0; }
else { $clear = int($clear); }
$self->_setfields($volume, $quota, $clear);
}
sub backupsys {
my $self = shift;
my ($prefix, $server, $partition, $exclude, $xprefix, $dryrun) = @_;
my (@Prefix, @XPrefix, $pcount);
if (!defined $dryrun) { $dryrun = 0; }
if (!defined $xprefix) { @XPrefix = (); }
elsif (! ref($xprefix)) { @XPrefix = split(/ /, $xprefix); }
else { @XPrefix = @{$xprefix}; }
if (!defined $exclude) { $exclude = 0; }
src/VOS/t/VOS.t view on Meta::CPAN
can_ok('AFS::VOS', qw(move));
can_ok('AFS::VOS', qw(offline));
can_ok('AFS::VOS', qw(online));
can_ok('AFS::VOS', qw(release));
can_ok('AFS::VOS', qw(remove));
can_ok('AFS::VOS', qw(rename));
can_ok('AFS::VOS', qw(restore));
can_ok('AFS::VOS', qw(setquota));
can_ok('AFS::VOS', qw(zap));
sub leak_test {
my $cell = shift;
my $count = 0;
my $verb = 1;
while(1) {
$count++;
my $vos = AFS::VOS->new($verb);
$vos->DESTROY();
if ($count == 1210) { last; }
}
src/inc/Test/Builder.pm view on Meta::CPAN
# Make Test::Builder thread-safe for ithreads.
BEGIN {
use Config;
if( $] >= 5.008 && $Config{useithreads} ) {
require threads;
require threads::shared;
threads::shared->import;
}
else {
*share = sub { 0 };
*lock = sub { 0 };
}
}
use vars qw($Level);
my($Test_Died) = 0;
my($Have_Plan) = 0;
my $Original_Pid = $$;
my $Curr_Test = 0; share($Curr_Test);
my @Test_Results = (); share(@Test_Results);
my @Test_Details = (); share(@Test_Details);
my $Test;
sub new {
my($class) = shift;
$Test ||= bless ['Move along, nothing to see here'], $class;
return $Test;
}
my $Exported_To;
sub exported_to {
my($self, $pack) = @_;
if( defined $pack ) {
$Exported_To = $pack;
}
return $Exported_To;
}
sub plan {
my($self, $cmd, $arg) = @_;
return unless $cmd;
if( $Have_Plan ) {
die sprintf "You tried to plan twice! Second plan at %s line %d\n",
($self->caller)[1,2];
}
if( $cmd eq 'no_plan' ) {
src/inc/Test/Builder.pm view on Meta::CPAN
require Carp;
my @args = grep { defined } ($cmd, $arg);
Carp::croak("plan() doesn't understand @args");
}
return 1;
}
my $Expected_Tests = 0;
sub expected_tests {
my($self, $max) = @_;
if( defined $max ) {
$Expected_Tests = $max;
$Have_Plan = 1;
$self->_print("1..$max\n") unless $self->no_header;
}
return $Expected_Tests;
}
my($No_Plan) = 0;
sub no_plan {
$No_Plan = 1;
$Have_Plan = 1;
}
sub has_plan {
return($Expected_Tests) if $Expected_Tests;
return('no_plan') if $No_Plan;
return(undef);
};
my $Skip_All = 0;
sub skip_all {
my($self, $reason) = @_;
my $out = "1..0";
$out .= " # Skip $reason" if $reason;
$out .= "\n";
$Skip_All = 1;
$self->_print($out) unless $self->no_header;
exit(0);
}
sub ok {
my($self, $test, $name) = @_;
# $test might contain an object which we don't want to accidentally
# store, so we turn it into a boolean.
$test = $test ? 1 : 0;
unless( $Have_Plan ) {
require Carp;
Carp::croak("You tried to run a test without a plan! Gotta have a plan.");
}
src/inc/Test/Builder.pm view on Meta::CPAN
unless( $test ) {
my $msg = $todo ? "Failed (TODO)" : "Failed";
$self->diag(" $msg test ($file at line $line)\n");
}
return $test ? 1 : 0;
}
sub is_eq {
my($self, $got, $expect, $name) = @_;
local $Level = $Level + 1;
if( !defined $got || !defined $expect ) {
# undef only matches undef and nothing else
my $test = !defined $got && !defined $expect;
$self->ok($test, $name);
$self->_is_diag($got, 'eq', $expect) unless $test;
return $test;
}
return $self->cmp_ok($got, 'eq', $expect, $name);
}
sub is_num {
my($self, $got, $expect, $name) = @_;
local $Level = $Level + 1;
if( !defined $got || !defined $expect ) {
# undef only matches undef and nothing else
my $test = !defined $got && !defined $expect;
$self->ok($test, $name);
$self->_is_diag($got, '==', $expect) unless $test;
return $test;
}
return $self->cmp_ok($got, '==', $expect, $name);
}
sub _is_diag {
my($self, $got, $type, $expect) = @_;
foreach my $val (\$got, \$expect) {
if( defined $$val ) {
if( $type eq 'eq' ) {
# quote and force string context
$$val = "'$$val'"
}
else {
# force numeric context
src/inc/Test/Builder.pm view on Meta::CPAN
}
return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
got: %s
expected: %s
DIAGNOSTIC
}
sub isnt_eq {
my($self, $got, $dont_expect, $name) = @_;
local $Level = $Level + 1;
if( !defined $got || !defined $dont_expect ) {
# undef only matches undef and nothing else
my $test = defined $got || defined $dont_expect;
$self->ok($test, $name);
$self->_cmp_diag('ne', $got, $dont_expect) unless $test;
return $test;
}
return $self->cmp_ok($got, 'ne', $dont_expect, $name);
}
sub isnt_num {
my($self, $got, $dont_expect, $name) = @_;
local $Level = $Level + 1;
if( !defined $got || !defined $dont_expect ) {
# undef only matches undef and nothing else
my $test = defined $got || defined $dont_expect;
$self->ok($test, $name);
$self->_cmp_diag('!=', $got, $dont_expect) unless $test;
return $test;
}
return $self->cmp_ok($got, '!=', $dont_expect, $name);
}
sub like {
my($self, $this, $regex, $name) = @_;
local $Level = $Level + 1;
$self->_regex_ok($this, $regex, '=~', $name);
}
sub unlike {
my($self, $this, $regex, $name) = @_;
local $Level = $Level + 1;
$self->_regex_ok($this, $regex, '!~', $name);
}
sub maybe_regex {
my ($self, $regex) = @_;
my $usable_regex = undef;
if( ref $regex eq 'Regexp' ) {
$usable_regex = $regex;
}
# Check if it looks like '/foo/'
elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) {
$usable_regex = length $opts ? "(?$opts)$re" : $re;
};
return($usable_regex)
};
sub _regex_ok {
my($self, $this, $regex, $cmp, $name) = @_;
local $Level = $Level + 1;
my $ok = 0;
my $usable_regex = $self->maybe_regex($regex);
unless (defined $usable_regex) {
$ok = $self->ok( 0, $name );
$self->diag(" '$regex' doesn't look much like a regex to me.");
return $ok;
src/inc/Test/Builder.pm view on Meta::CPAN
%s
%13s '%s'
DIAGNOSTIC
}
return $ok;
}
sub cmp_ok {
my($self, $got, $type, $expect, $name) = @_;
my $test;
{
local $^W = 0;
local($@,$!); # don't interfere with $@
# eval() sometimes resets $!
$test = eval "\$got $type \$expect";
}
local $Level = $Level + 1;
src/inc/Test/Builder.pm view on Meta::CPAN
if( $type =~ /^(eq|==)$/ ) {
$self->_is_diag($got, $type, $expect);
}
else {
$self->_cmp_diag($got, $type, $expect);
}
}
return $ok;
}
sub _cmp_diag {
my($self, $got, $type, $expect) = @_;
$got = defined $got ? "'$got'" : 'undef';
$expect = defined $expect ? "'$expect'" : 'undef';
return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
%s
%s
%s
DIAGNOSTIC
}
sub BAILOUT {
my($self, $reason) = @_;
$self->_print("Bail out! $reason");
exit 255;
}
sub skip {
my($self, $why) = @_;
$why ||= '';
unless( $Have_Plan ) {
require Carp;
Carp::croak("You tried to run tests without a plan! Gotta have a plan.");
}
lock($Curr_Test);
$Curr_Test++;
src/inc/Test/Builder.pm view on Meta::CPAN
$out .= " $Curr_Test" if $self->use_numbers;
$out .= " # skip $why\n";
$Test->_print($out);
return 1;
}
sub todo_skip {
my($self, $why) = @_;
$why ||= '';
unless( $Have_Plan ) {
require Carp;
Carp::croak("You tried to run tests without a plan! Gotta have a plan.");
}
lock($Curr_Test);
$Curr_Test++;
src/inc/Test/Builder.pm view on Meta::CPAN
$out .= " $Curr_Test" if $self->use_numbers;
$out .= " # TODO & SKIP $why\n";
$Test->_print($out);
return 1;
}
sub level {
my($self, $level) = @_;
if( defined $level ) {
$Level = $level;
}
return $Level;
}
$CLASS->level(1);
my $Use_Nums = 1;
sub use_numbers {
my($self, $use_nums) = @_;
if( defined $use_nums ) {
$Use_Nums = $use_nums;
}
return $Use_Nums;
}
my($No_Header, $No_Ending) = (0,0);
sub no_header {
my($self, $no_header) = @_;
if( defined $no_header ) {
$No_Header = $no_header;
}
return $No_Header;
}
sub no_ending {
my($self, $no_ending) = @_;
if( defined $no_ending ) {
$No_Ending = $no_ending;
}
return $No_Ending;
}
sub diag {
my($self, @msgs) = @_;
return unless @msgs;
# Prevent printing headers when compiling (i.e. -c)
return if $^C;
# Escape each line with a #.
foreach (@msgs) {
$_ = 'undef' unless defined;
s/^/# /gms;
src/inc/Test/Builder.pm view on Meta::CPAN
local $Level = $Level + 1;
my $fh = $self->todo ? $self->todo_output : $self->failure_output;
local($\, $", $,) = (undef, ' ', '');
print $fh @msgs;
return 0;
}
sub _print {
my($self, @msgs) = @_;
# Prevent printing headers when only compiling. Mostly for when
# tests are deparsed with B::Deparse
return if $^C;
local($\, $", $,) = (undef, ' ', '');
my $fh = $self->output;
# Escape each line after the first with a # so we don't
src/inc/Test/Builder.pm view on Meta::CPAN
}
push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/;
print $fh @msgs;
}
my($Out_FH, $Fail_FH, $Todo_FH);
sub output {
my($self, $fh) = @_;
if( defined $fh ) {
$Out_FH = _new_fh($fh);
}
return $Out_FH;
}
sub failure_output {
my($self, $fh) = @_;
if( defined $fh ) {
$Fail_FH = _new_fh($fh);
}
return $Fail_FH;
}
sub todo_output {
my($self, $fh) = @_;
if( defined $fh ) {
$Todo_FH = _new_fh($fh);
}
return $Todo_FH;
}
sub _new_fh {
my($file_or_fh) = shift;
my $fh;
unless( UNIVERSAL::isa($file_or_fh, 'GLOB') ) {
$fh = do { local *FH };
open $fh, ">$file_or_fh" or
die "Can't open test output log $file_or_fh: $!";
}
else {
$fh = $file_or_fh;
src/inc/Test/Builder.pm view on Meta::CPAN
_autoflush(\*TESTOUT);
_autoflush(\*STDOUT);
_autoflush(\*TESTERR);
_autoflush(\*STDERR);
$CLASS->output(\*TESTOUT);
$CLASS->failure_output(\*TESTERR);
$CLASS->todo_output(\*TESTOUT);
}
sub _autoflush {
my($fh) = shift;
my $old_fh = select $fh;
$| = 1;
select $old_fh;
}
sub current_test {
my($self, $num) = @_;
lock($Curr_Test);
if( defined $num ) {
unless( $Have_Plan ) {
require Carp;
Carp::croak("Can't change the current test number without a plan!");
}
$Curr_Test = $num;
src/inc/Test/Builder.pm view on Meta::CPAN
);
$Test_Results[$_] = \%result;
}
}
}
return $Curr_Test;
}
sub summary {
my($self) = shift;
return map { $_->{'ok'} } @Test_Results;
}
sub details {
return @Test_Results;
}
sub todo {
my($self, $pack) = @_;
$pack = $pack || $self->exported_to || $self->caller(1);
no strict 'refs';
return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
: 0;
}
sub caller {
my($self, $height) = @_;
$height ||= 0;
my @caller = CORE::caller($self->level + $height + 1);
return wantarray ? @caller : $caller[0];
}
sub _sanity_check {
_whoa($Curr_Test < 0, 'Says here you ran a negative number of tests!');
_whoa(!$Have_Plan and $Curr_Test,
'Somehow your tests ran without a plan!');
_whoa($Curr_Test != @Test_Results,
'Somehow you got a different number of results than tests ran!');
}
sub _whoa {
my($check, $desc) = @_;
if( $check ) {
die <<WHOA;
WHOA! $desc
This should never happen! Please contact the author immediately!
WHOA
}
}
sub _my_exit {
$? = $_[0];
return 1;
}
$SIG{__DIE__} = sub {
# We don't want to muck with death in an eval, but $^S isn't
# totally reliable. 5.005_03 and 5.6.1 both do the wrong thing
# with it. Instead, we use caller. This also means it runs under
# 5.004!
my $in_eval = 0;
for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) {
$in_eval = 1 if $sub =~ /^\(eval\)/;
}
$Test_Died = 1 unless $in_eval;
};
sub _ending {
my $self = shift;
_sanity_check();
# Don't bother with an ending if this is a forked copy. Only the parent
# should do the ending.
do{ _my_exit($?) && return } if $Original_Pid != $$;
# Bailout if plan() was never called. This is so
# "require Test::Simple" doesn't puke.
src/inc/Test/More.pm view on Meta::CPAN
use 5.004;
use strict;
use Test::Builder;
# Can't use Carp because it might cause use_ok() to accidentally succeed
# even though the module being used forgot to use Carp. Yes, this
# actually happened.
sub _carp {
my($file, $line) = (caller(1))[1,2];
warn @_, " at $file line $line\n";
}
require Exporter;
use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
$VERSION = '0.47';
@ISA = qw(Exporter);
src/inc/Test/More.pm view on Meta::CPAN
$TODO
plan
can_ok isa_ok
diag
);
my $Test = Test::Builder->new;
# 5.004's Exporter doesn't have export_to_level.
sub _export_to_level
{
my $pkg = shift;
my $level = shift;
(undef) = shift; # redundant arg
my $callpkg = caller($level);
$pkg->export($callpkg, @_);
}
sub plan {
my(@plan) = @_;
my $caller = caller;
$Test->exported_to($caller);
my @imports = ();
foreach my $idx (0..$#plan) {
if( $plan[$idx] eq 'import' ) {
my($tag, $imports) = splice @plan, $idx, 2;
@imports = @$imports;
last;
}
}
$Test->plan(@plan);
__PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
}
sub import {
my($class) = shift;
goto &plan;
}
sub ok ($;$) {
my($test, $name) = @_;
$Test->ok($test, $name);
}
sub is ($$;$) {
$Test->is_eq(@_);
}
sub isnt ($$;$) {
$Test->isnt_eq(@_);
}
*isn't = \&isnt;
sub like ($$;$) {
$Test->like(@_);
}
sub unlike {
$Test->unlike(@_);
}
sub cmp_ok($$$;$) {
$Test->cmp_ok(@_);
}
sub can_ok ($@) {
my($proto, @methods) = @_;
my $class = ref $proto || $proto;
unless( @methods ) {
my $ok = $Test->ok( 0, "$class->can(...)" );
$Test->diag(' can_ok() called with no methods');
return $ok;
}
my @nok = ();
src/inc/Test/More.pm view on Meta::CPAN
: "$class->can(...)";
my $ok = $Test->ok( !@nok, $name );
$Test->diag(map " $class->can('$_') failed\n", @nok);
return $ok;
}
sub isa_ok ($$;$) {
my($object, $class, $obj_name) = @_;
my $diag;
$obj_name = 'The object' unless defined $obj_name;
my $name = "$obj_name isa $class";
if( !defined $object ) {
$diag = "$obj_name isn't defined";
}
elsif( !ref $object ) {
$diag = "$obj_name isn't a reference";
src/inc/Test/More.pm view on Meta::CPAN
}
else {
$ok = $Test->ok( 1, $name );
}
return $ok;
}
sub pass (;$) {
$Test->ok(1, @_);
}
sub fail (;$) {
$Test->ok(0, @_);
}
sub diag {
$Test->diag(@_);
}
sub use_ok ($;@) {
my($module, @imports) = @_;
@imports = () unless @imports;
my $pack = caller;
local($@,$!); # eval sometimes interferes with $!
eval <<USE;
package $pack;
require $module;
'$module'->import(\@imports);
src/inc/Test/More.pm view on Meta::CPAN
Tried to use '$module'.
Error: $@
DIAGNOSTIC
}
return $ok;
}
sub require_ok ($) {
my($module) = shift;
my $pack = caller;
local($!, $@); # eval sometimes interferes with $!
eval <<REQUIRE;
package $pack;
require $module;
REQUIRE
src/inc/Test/More.pm view on Meta::CPAN
$Test->diag(<<DIAGNOSTIC);
Tried to require '$module'.
Error: $@
DIAGNOSTIC
}
return $ok;
}
sub skip {
my($why, $how_many) = @_;
unless( defined $how_many ) {
# $how_many can only be avoided when no_plan is in use.
_carp "skip() needs to know \$how_many tests are in the block"
unless $Test::Builder::No_Plan;
$how_many = 1;
}
for( 1..$how_many ) {
$Test->skip($why);
}
local $^W = 0;
last SKIP;
}
sub todo_skip {
my($why, $how_many) = @_;
unless( defined $how_many ) {
# $how_many can only be avoided when no_plan is in use.
_carp "todo_skip() needs to know \$how_many tests are in the block"
unless $Test::Builder::No_Plan;
$how_many = 1;
}
for( 1..$how_many ) {
$Test->todo_skip($why);
}
local $^W = 0;
last TODO;
}
use vars qw(@Data_Stack);
my $DNE = bless [], 'Does::Not::Exist';
sub is_deeply {
my($this, $that, $name) = @_;
my $ok;
if( !ref $this || !ref $that ) {
$ok = $Test->is_eq($this, $that, $name);
}
else {
local @Data_Stack = ();
if( _deep_check($this, $that) ) {
$ok = $Test->ok(1, $name);
}
else {
$ok = $Test->ok(0, $name);
$ok = $Test->diag(_format_stack(@Data_Stack));
}
}
return $ok;
}
sub _format_stack {
my(@Stack) = @_;
my $var = '$FOO';
my $did_arrow = 0;
foreach my $entry (@Stack) {
my $type = $entry->{type} || '';
my $idx = $entry->{'idx'};
if( $type eq 'HASH' ) {
$var .= "->" unless $did_arrow++;
$var .= "{$idx}";
src/inc/Test/More.pm view on Meta::CPAN
}
$out .= "$vars[0] = $vals[0]\n";
$out .= "$vars[1] = $vals[1]\n";
$out =~ s/^/ /msg;
return $out;
}
sub eq_array {
my($a1, $a2) = @_;
return 1 if $a1 eq $a2;
my $ok = 1;
my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
for (0..$max) {
my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] };
$ok = _deep_check($e1,$e2);
pop @Data_Stack if $ok;
last unless $ok;
}
return $ok;
}
sub _deep_check {
my($e1, $e2) = @_;
my $ok = 0;
my $eq;
{
# Quiet uninitialized value warnings when comparing undefs.
local $^W = 0;
if( $e1 eq $e2 ) {
$ok = 1;
src/inc/Test/More.pm view on Meta::CPAN
$ok = 0;
}
}
}
return $ok;
}
sub eq_hash {
my($a1, $a2) = @_;
return 1 if $a1 eq $a2;
my $ok = 1;
my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
foreach my $k (keys %$bigger) {
my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] };
$ok = _deep_check($e1, $e2);
pop @Data_Stack if $ok;
last unless $ok;
}
return $ok;
}
sub _bogus_sort { local $^W = 0; ref $a ? 0 : $a cmp $b }
sub eq_set {
my($a1, $a2) = @_;
return 0 unless @$a1 == @$a2;
# There's faster ways to do this, but this is easiest.
return eq_array( [sort _bogus_sort @$a1], [sort _bogus_sort @$a2] );
}
sub builder {
return Test::Builder->new;
}
1;
src/inc/version.pm view on Meta::CPAN
*{'version::(""'} = \&version::vxs::stringify;
*{'version::(<=>'} = \&version::vxs::VCMP;
*version::new = \&version::vxs::new;
*version::parse = \&version::vxs::parse;
}
}
}
# Preloaded methods go here.
sub import {
no strict 'refs';
my ($class) = shift;
# Set up any derived class
unless ($class eq 'version') {
local $^W;
*{$class.'::declare'} = \&version::declare;
*{$class.'::qv'} = \&version::qv;
}
src/inc/version.pm view on Meta::CPAN
(
qv => 1,
'UNIVERSAL::VERSION' => 1,
);
}
my $callpkg = caller();
if (exists($args{declare})) {
*{$callpkg.'::declare'} =
sub {return $class->declare(shift) }
unless defined(&{$callpkg.'::declare'});
}
if (exists($args{qv})) {
*{$callpkg.'::qv'} =
sub {return $class->qv(shift) }
unless defined(&{$callpkg.'::qv'});
}
if (exists($args{'UNIVERSAL::VERSION'})) {
local $^W;
*UNIVERSAL::VERSION
= \&version::_VERSION;
}
if (exists($args{'VERSION'})) {
src/inc/version.pm view on Meta::CPAN
*{$callpkg.'::is_strict'} = \&version::is_strict
unless defined(&{$callpkg.'::is_strict'});
}
if (exists($args{'is_lax'})) {
*{$callpkg.'::is_lax'} = \&version::is_lax
unless defined(&{$callpkg.'::is_lax'});
}
}
sub is_strict { defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x }
sub is_lax { defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x }
1;
( run in 1.442 second using v1.01-cache-2.11-cpan-4d50c553e7e )