^sub \w+\( results from the CPAN

    mirror
    toggle_cistrans
    valence
);

sub is_chiral($);
sub is_chiral_planar($);
sub is_chiral_tetrahedral($);
sub mirror($);
sub toggle_cistrans($);

our %normal_valence = (
    B  => [ 3 ],
    C  => [ 4 ],
    N  => [ 3, 5 ],

# For square planar arrangements this means situations when all neighbours are the same.
# Chiral centers with lone pairs are left untouched.
# Returns the affected atoms.
#
# TODO: check other chiral centers
sub clean_chiral_centers($$)
{
    my( $moiety, $color_sub ) = @_;

    my @affected;
    for my $atom ($moiety->vertices) {

    }

    return @affected;
}

sub is_aromatic($)
{
    my( $atom ) = @_;
    return $atom->{symbol} ne ucfirst $atom->{symbol};
}

    my( $moiety, $a, $b ) = @_;
    return $moiety->has_edge_attribute( $a, $b, 'bond' ) &&
           $moiety->get_edge_attribute( $a, $b, 'bond' ) eq ':';
}

sub is_chiral($)
{
    my( $what ) = @_;
    if( ref $what eq 'HASH' ) { # Single atom
        return exists $what->{chirality};
    } else {                    # Graph representing moiety
        return any { is_chiral( $_ ) } $what->vertices;
    }
}

sub is_chiral_allenal($)
{
    my( $what ) = @_;
    if( ref $what eq 'HASH' ) { # Single atom
        return $what->{chirality} && $what->{chirality} =~ /^\@AL[12]$/;
    } else {                    # Graph representing moiety
        return any { is_chiral_allenal( $_ ) } $what->vertices;
    }
}

sub is_chiral_planar($)
{
    my( $what ) = @_;
    if( ref $what eq 'HASH' ) { # Single atom
        return $what->{chirality} && $what->{chirality} =~ /^\@SP[123]$/;
    } else {                    # Graph representing moiety
        return any { is_chiral_planar( $_ ) } $what->vertices;
    }
}

sub is_chiral_tetrahedral($)
{
    my( $what ) = @_;
    if( ref $what eq 'HASH' ) { # Single atom
        # CAVEAT: will fail for allenal configurations of @/@@ in raw mode
        return $what->{chirality} && $what->{chirality} =~ /^@@?$/;
    } else {                    # Graph representing moiety
        return any { is_chiral_tetrahedral( $_ ) } $what->vertices;
    }
}

sub is_chiral_trigonal_bipyramidal($)
{
    my( $what ) = @_;
    if( ref $what eq 'HASH' ) { # Single atom
        return $what->{chirality} && $what->{chirality} =~ /^\@TB([1-9]|1[0-9]|20)$/;
    } else {                    # Graph representing moiety
        return any { is_chiral_trigonal_bipyramidal( $_ ) } $what->vertices;
    }
}

sub is_chiral_octahedral($)
{
    my( $what ) = @_;
    if( ref $what eq 'HASH' ) { # Single atom
        return $what->{chirality} && $what->{chirality} =~ /^\@OH([1-9]|[12][0-9]|30)$/;
    } else {                    # Graph representing moiety

    my( $moiety, $a, $b ) = @_;
    return $moiety->has_edge_attribute( $a, $b, 'bond' ) &&
           $moiety->get_edge_attribute( $a, $b, 'bond' ) eq '#';
}

sub mirror($)
{
    my( $what ) = @_;
    if( ref $what eq 'HASH' ) { # Single atom
        if( is_chiral_tetrahedral( $what ) ) {
            $what->{chirality} = $what->{chirality} eq '@' ? '@@' : '@';

            mirror( $_ );
        }
    }
}

sub toggle_cistrans($)
{
    return $_[0] unless $_[0] =~ /^[\\\/]$/;
    return $_[0] eq '/' ? '\\' : '/';
}

# TODO: The actual unsprouting has to happen during print.
sub _unsprout_hydrogens($)
{
    my( $moiety ) = @_;

    for my $atom ($moiety->vertices) {
        next unless can_unsprout_hydrogen( $moiety, $atom );

        $neighbour->{hcount}++;
        $moiety->delete_vertex( $atom );
    }
}

sub valence($$)
{
    my( $moiety, $atom ) = @_;
    return ($atom->{hcount} ? $atom->{hcount} : 0) +
           sum0 map { exists $bond_symbol_to_order{$_}
                           ? $bond_symbol_to_order{$_}

                           : 1 }
                    $moiety->neighbours( $atom );
}

# CAVEAT: requires output from non-raw parsing due issue similar to GH#2
sub _validate($@)
{
    my( $moiety, $color_sub ) = @_;

    # Identify islands of allene systems
    my $allenes = _allene_graph( $moiety );

view all matches for this distribution

Chess-Opening

1 match

t/get-key.t view on Meta::CPAN

use Test::More;
use Chess::Opening::Book::Polyglot;

# Tests from http://hardy.uhasselt.be/Toga/book_format.html

sub stringify_key($);

my ($key);

$key = Chess::Opening::Book::Polyglot->_getKey(
	'rnbqkbnr/pppppppp/8/8/8/8/PPPPPPPP/RNBQKBNR w KQkq - 0 1'

t/get-key.t view on Meta::CPAN

);
is stringify_key $key, "0x5c3f9b829b279560";

done_testing;

sub stringify_key($) {
	my @bytes = unpack 'C*', shift;

	my $retval = '0x';
	foreach my $byte (@bytes) {
		$retval .= sprintf '%02x', $byte;

view all matches for this distribution

Child

1 match

lib/Child.pm view on Meta::CPAN

our @PROCS;
our @EXPORT_OK = qw/child/;

add_accessors qw/code/;

sub child(&;@) {
    my ( $code, @params ) = @_;
    my $caller = caller;
    return __PACKAGE__->new( $code, @params )->start;
}

view all matches for this distribution

Chipcard-PCSC

2 results

Card/Card.pm view on Meta::CPAN


# Usage:
# $text = ISO7816Error($sw)
#
# return the text version of the ISO 7816-4 error given in $sw
sub ISO7816Error($)
{
	my $sw = shift;

	# default error message
	my $text = "Error not defined by ISO 7816";

view all matches for this distribution

Cindy-Apache2

2 results

}

#
# Read data of the given kind into a stringref
#
sub read_subrequest($$$;$)
{
  my ($r, $what, $rtext, $rtype) = @_;
  my $rsub = lookup_by_env($r, $what);
  if (!defined($rsub)) {
    return Apache2::Const::HTTP_NOT_FOUND;


#
# Reads a subrequests LastModified header and sets it
# for the main request 
#
sub copy_mtime($$)
{
  my ($from, $to) = @_;
  # If no mtime is available 
  # we asume the document has just 
  # been created.

}

#
# return An apache subrequest object
# 
sub lookup_by_env($$)
{
  my ($r, $pname) = @_;

  my $rtn;
  my $env_file = $r->subprocess_env("CINDY_$pname"."_FILE");

}

#
# return An XML:LibXML root node.
# 
sub parse_by_type($$$)
{
  my ($type, $text, $what) = @_;

  my $rtn;

view all matches for this distribution

Cindy

6 results

lib/Cindy.pm view on Meta::CPAN


use XML::LibXML;
use Cindy::Sheet;
use Cindy::Log;
 
sub get_html_doc($)
{
  my ($file)  = @_;
  my $parser = XML::LibXML->new();

  return $parser->parse_html_file($file);
}

sub get_xml_doc($)
{
  my ($file)  = @_;
  my $parser = XML::LibXML->new();

  return $parser->parse_file($file);

lib/Cindy.pm view on Meta::CPAN

  
    $parent->removeChild($node);
  }
}

sub parse_html_string($;$)
{
  my ($string, $ropt)  = @_;
  $ropt ||= {};
  
  my $html_parse_noimplied = $ropt->{html_parse_noimplied}

lib/Cindy.pm view on Meta::CPAN

    omit_nodes($doc, 'body');
  }
  return $doc;
}

sub parse_xml_string($)
{
  my $parser = XML::LibXML->new();

  return $parser->parse_string($_[0]);
}

sub parse_cis($)
{
  return Cindy::Sheet::parse_cis($_[0]);
}

sub parse_cis_string($)
{
  return Cindy::Sheet::parse_cis_string($_[0]);
}

#
# Get a copied doc. root for modification.
#
sub get_root_copy($)
{
  my ($doc)   = @_;
  my $root  = $doc->documentElement();
  my $rtn = $root->cloneNode( 1 );
  return $rtn;
}

sub dump_xpath_profile()
{
  Cindy::Injection::dump_profile();
}

sub inject($$$)
{
  my ($data, $doc, $descriptions) = @_;
  my $docroot = get_root_copy($doc);
#  my $dataroot = get_root_copy($data);
  my $dataroot = $data->getDocumentElement();

view all matches for this distribution

CircuitLayout

2 results

=head1 CircuitLayout::Coord::coordSubtract

=cut

####### CircuitLayout::Coord
sub coordSubtract($$$)
{
    my $self = shift;
    my $coordA = shift;
    my $coordB = shift;
    my $x = $coordA -> x;

=head1 CircuitLayout::Coord::snapNum

=cut

####### CircuitLayout::Coord
sub snapNum($$$)
{
    my $num=shift;
    my $snap=shift;
    my $resolution=shift;
    $snap =~ s|0+$||;

    }
    $num;
}
################################################################

sub triangleArea($$$$$$)
{
    my ($x0,$y0,$x1,$y1,$x2,$y2) = @_;

    ( ($x1 - $x0) * ($y2 - $y0) -
      ($x2 - $x0) * ($y1 - $y0)


=head1 CircuitLayout::version

=cut

sub version()
{
    return $VERSION;
}
################################################################################

=head1 CircuitLayout::revision

=cut

sub revision()
{
    return $revision;
}
################################################################################

view all matches for this distribution

Cisco-Accounting

3 results

use Cisco::Accounting::Interface;	## object that represents a single interface
use Cisco::Accounting::Data;		## object that represents the parsed accounting data



sub new()  {
	my ($this, %parms) = @_;
	my  $class = ref($this) || $this;
	my  $self = {};	
	
	$self->{'session'} = '';	# this will contain our session to Net::Telnet::Wrapper

##
## fetch all interfaces on a cisco device that support ip accounting
## returns array of Cisco::Accounting::Interface objects
## this procedured should be used with eval {}
##
sub get_interfaces()  {
	my ($self) = shift;
	
	my $disconnect;
	my @interfaces;	# resulting array of Cisco::Accounting::Interface objects

## Disable ip accounting on one or more interfaces
## parameters = array of interface id's as known in $self->{'interfaces'}
## ** this assumes you've run get_interfaces first ! **
## ** this assumes that you have enough rights to go to config mode **
##
sub enable_accounting()  {
	my ($self) = shift;
	my (@int_id) = @_;
	
	$self->_modify_accounting_settings(1, @int_id);
}

## Disable ip accounting on one or more interfaces
## parameters = array of interface id's as known in $self->{'interfaces'}
## ** this assumes you've run get_interfaces first ! **
## ** this assumes that you have enough rights to go to config mode **
##
sub disable_accounting()  {
	my ($self) = shift;
	my (@int_id) = @_;
	
	$self->_modify_accounting_settings(0, @int_id);
}

##
## parse output of 1 poll (show ip accounting) and update $self->{'data'}
## returns the reference to the output
## this procedure should be used with eval{}
##
sub do_accounting()  {
	my ($self) = shift;

	my (@output);
	my $disconnect = 0;



##
## returns a reference to the output
##
sub get_output()  {
	my ($self) = shift;
	
	if ($self->{'data'})  {
		return $self->{'data'}->get_data();
	}



##
## returns a reference to the output
##
sub get_lastpoll_output()  {
	my ($self) = shift;
	
	if ($self->{'lastpoll_data'})  {
		return $self->{'lastpoll_data'}->get_data();
	}

}

##
## return reference to hash with polling statistics
##
sub get_statistics()  {
	my ($self) = shift;
	
	if ($self->{'data'})  {
		return	$self->{'data'}->get_stats();
	}



##
## return reference to hash with polling statistics
##
sub get_history()  {
	my ($self) = shift;
	
	if ($self->{'data'})  {
		return	$self->{'data'}->get_history();
	}

}

##
## clears the output buffer
##
sub clear_output()  {
	my ($self) = shift;
	
	$self->{'data'} = '';
}


##
## clears ip accounting information on the remote device
## this procedure should be used with eval {}
##
sub clear_accounting()  {
	my ($self) = shift;
	
	my $disconnect = 0;
	
	# if the connection is not yet active then we assume that it has to be closed again


##
## Send a keepalive (new line character), do not do any error checking here
## Useful if 'persistent' is enabled, but still it's up to you to call the keepalive in time before session times out
##
sub keepalive()  {
	my ($self) = shift;
	
	if ($self->{'session'})  {
		eval  {
			$self->{'session'}->cmd(" ");

### TODO: do not go to config mode unless really needed

##
## Enable (1) or Disable (0) ip accounting depending on $status
##
sub _modify_accounting_settings()  {
	my ($self) = shift;
	my ($status) = shift;
	my (@int_id) = @_;
	
	## IPCAD interfaces are always enabled



##
## open a new telnet connection, login and save session in $self->{'session'}
##
sub _connect()  {
	my ($self) = shift;
	
	my $device_class;
	my $enable = 1;



##
## close telnet connection, remove session from $self->{'session'}
##
sub _disconnect()  {
	my ($self) = shift;
	
	return unless ($self->{'session'});
	
	eval {


##
## fetch all interfaces on a cisco device that support ip accounting
## returns array of Cisco::Accounting::Interface objects
##
sub _parse_cisco_interfaces()  {
	my ($interfaces) = shift;
	
	my ($int);
	my (@result);
	my ($current_int);


##
## fetch all interfaces from a host running IPCAD
## returns array of Cisco::Accounting::Interface objects
##
sub _parse_ipcad_interfaces()  {
	my ($interfaces) = shift;

	my ($int);
	my (@result);
	my ($current_int);

view all matches for this distribution

Cisco-Conf

1 match

lib/Cisco/Conf.pm view on Meta::CPAN

    if (!$fh->close()) {
	die "Fatal error while writing $file, contents may be destroyed: $!";
    }
}

sub Add($$$) {
    my($class, $file, $attrs) = @_;
    my($config) = $class->_ReadConfigFile($file);

    if ($< != 0  ||  $> != 0) {
	die "Must be root to add new routers.\n";

lib/Cisco/Conf.pm view on Meta::CPAN


Only root may add or remove configurations.

=cut

sub Remove($$$) {
    my($class, $file, $name) = @_;

    if ($< != 0  ||  $> != 0) {
	die "Must be root to remove routers.\n";
    }

lib/Cisco/Conf.pm view on Meta::CPAN

    $self->Edit('emacs', 'myrouter.conf', '/tmp');

=cut


sub _System($$) {
    my($class, $command) = @_;
    $! = 0;
    my $rc = system $command;
    if ($rc == 0xff00) {
	die "Command $command failed: " .

view all matches for this distribution

Cisco-Version

2 results

		'flash_largest_size'		=>	'flash_largest_size',
	);



sub new()  {
	my ($this, $show_version) = @_;
	my  $class = ref($this) || $this;
	my  $self = {};	
	
	$self->{'show_version'} = $show_version;	# full output of "show version"


}



sub AUTOLOAD()  {
	my ($self,@args) = @_;
	my $cmd = $Cisco::Version::AUTOLOAD;
	my $parm;
	
	$cmd =~ s/.*:://;

}




sub get_parameter()  {
	my ($self, $parm) = @_;
	
	if (defined($self->{'parsed'}->{$CMD{"$parm"}}))  {
		return $self->{'parsed'}->{$CMD{"$parm"}};
	}


##
## returns a reference to the 'parsed' hash,
## this contains all the elements that were found in 'show version'
##
sub get_summary()  {
	my ($self) = shift;
	
	return $self->{'parsed'};
}


sub get_not_found_value()  {
	my ($self) = shift;
	
	return $self->{'not_found'};
}

sub set_not_found_value()  {
	my ($self, $value) = @_;
	
	$self->{'not_found'} = $value if (defined($value));
}


## look for bootstrap version
sub _process_rom()  {
	my ($self, $line) = @_;
	my $version;
	
	&_debug("parsing bootstrap", $line);

		}
	}
}


sub _process_software_version()  {
	my ($self, $line) = @_;
	my ($sw_version, $sw_type, $sw_featureset);

	&_debug("parsing software version", $line);

	}
}



sub _process_bootloader()  {
	my ($self, $line) = @_;
	my ($bl_version, $bl_type, $bl_featureset);

	&_debug("parsing bootloader", $line);

	}
}



sub _process_uptime()  {
	my ($self, $line) = @_;
	my ($host, $uptime);

	&_debug("parsing uptime", $line);

	}
}



sub _process_reload_reason()  {
	my ($self, $line) = @_;
	my $reason;

	&_debug("parsing reload reason", $line);

		&_error("reload reason cannot be parsed", $line);
	}
}


sub _process_reload_time()  {
	my ($self, $line) = @_;
	my $time;

	&_debug("parsing reload time", $line);

		&_error("reload time cannot be parsed", $line);
	}
}


sub _process_image_file()  {
	my ($self, $line) = @_;
	my $image;

	&_debug("parsing image file info", $line);

## tries to calculate the memory
## This is no exact science so be careful ...
##  Here's how we do it by default to get memory in MB : (main memory + shared IO memory) / 1024
## But there are a few exceptions.
## 
sub _process_memory()  {
	my ($self, $line) = @_;
	my ($memory, $chassis);
	my ($main_mem, $io_mem);

	&_debug("parsing memory", $line);


##
## some smaller routers have extra line with 'additional' DRAM
## this should be added to the RAM we already found
##
sub _process_additional_memory() {
	my ($self, $line) = @_;
	my ($memory);
	
	if ($line =~ /([0-9]+)M .* of physical memory \(DRAM\)$/)  {
		$memory = int($1 + .5);

}




sub _process_configuration_register()  {
	my ($self, $line) = @_;
	my ($confreg);

	&_debug("parsing configuration register", $line);

		&_error("unable to parse configuration register", $line);
	}
}


sub _process_password_recovery()  {
	my ($self, $line) = @_;
	my ($recovery);

	&_debug("parsing password recovery mechanism", $line);

## we try to parse :
##
## List of all flash filesystem sizes is kept as flash_filesystems_sizes
## Largest flash filesystem is reported as flash_largest_size
##
sub _process_flash()  {
	my ($self, $line) = @_;
	my ($flash);
	
	&_debug("parsing flash info", $line);



##
## carp a log message, regardless of $DEBUG value
##
sub _log()  {
	my ($msg, $line) = @_;
	
	if ($line)  {
		$msg = $msg . " [$line]";
	}



##
## carp a log message, only if $DEBUG >= 1
##
sub _error()  {
	my ($msg, $line) = @_;
	
	if ($DEBUG >= 1)  {
		&_log("ERROR: ".$msg, $line);
	}



##
## carp a log message, only if $DEBUG >= 2
##
sub _warn()  {
	my ($msg, $line) = @_;
	
	if ($DEBUG >= 2)  {
		&_log("WARN: ".$msg, $line);
	}



##
## carp a log message, only if $DEBUG >= 3
##
sub _info()  {
	my ($msg, $line) = @_;
	
	if ($DEBUG >= 3)  {
		&_log("INFO: ".$msg, $line);
	}



##
## carp a log message, only if $DEBUG >= 3
##
sub _debug()  {
	my ($msg, $line) = @_;
	
	if ($DEBUG >= 4)  {
		&_log("DEBUG: ".$msg, $line);
	}

view all matches for this distribution

Class-Accessor-TrackDirty

1 match

lib/Class/Accessor/TrackDirty.pm view on Meta::CPAN

        my $package = shift;
        $package_info{$package} ||= {tracked_fields => {}, fields => {}};
    }
}

sub _is_different_deeply($$) {
    my ($ref_x, $ref_y) = @_;
    (freeze $ref_x) ne (freeze $ref_y);
}

sub _is_different($$) {
    my ($x, $y) = @_;
    if (defined $x && defined $y) {
        if (ref $x && ref $y) {
            return _is_different_deeply $x, $y;
        } else {

lib/Class/Accessor/TrackDirty.pm view on Meta::CPAN

    } else {
        return defined $x || defined $y;
    }
}

sub _make_tracked_accessor($$) {
    no strict 'refs';
    my ($package, $name) = @_;

    *{"$package\::$name"} = sub {
        my $self = shift;

lib/Class/Accessor/TrackDirty.pm view on Meta::CPAN


        return $value;
    };
}

sub _make_accessor($$) {
    no strict 'refs';
    my ($package, $name) = @_;

    *{"$package\::$name"} = sub {
        my $self = shift;

lib/Class/Accessor/TrackDirty.pm view on Meta::CPAN

        $self->{$name} = $_[0] if @_;
        $value;
    };
}

sub _mk_tracked_accessors($@) {
    my $package = shift;
    _make_tracked_accessor $package => $_ for @_;
    @{(_package_info $package)->{tracked_fields}}{@_} = (1,) x @_;
}

sub _mk_helpers($) {
    no strict 'refs';
    my $package = shift;
    my ($tracked_fields, $fields) =
        @{_package_info $package}{qw(tracked_fields fields)};

lib/Class/Accessor/TrackDirty.pm view on Meta::CPAN

        my $self = shift;
        delete $self->{$_} for keys %$tracked_fields;
    };
}

sub _mk_accessors($@) {
    my $package = shift;
    _make_accessor $package => $_ for @_;
    @{(_package_info $package)->{fields}}{@_} = (1,) x @_;
}

sub _mk_new($) {
    no strict 'refs';
    my $package = shift;

    *{"$package\::$NEW"} = sub {
        my $package = shift;

view all matches for this distribution

Class-Attrib

1 match

Attrib.pm view on Meta::CPAN


Returns the newly assigned value, for convenience.

=cut

sub Attrib($;$;$) {
	my $this = shift;
	my $class = ref( $this ) || $this;

	unless ( @_ ) {
		my %attribs = ();

Attrib.pm view on Meta::CPAN


{ # private lexicals begin

my %values;

sub attrib($;$;$) {
	my $self = shift;

	# class reference, might want to test or change a default
	return $self->Attrib( @_ ) unless ref $self;

view all matches for this distribution

Class-AutoGenerate

3 results

lib/Class/AutoGenerate.pm view on Meta::CPAN


Returns true if the package named was autogenerated by a L<Class::AutoGenerate> class loader. Returns C<undef> in any other case.

=cut

sub autogenerated($) {
    my $class = shift;
    if (blessed $class or (not ref $class and $class =~ /^[:\w]+$/)) {
        $class = shift if $class->isa('Class::AutoGenerate');
    }

lib/Class/AutoGenerate.pm view on Meta::CPAN


Returns the object that was used to autogenerate the module. This is really just a shortcut for looking up the information in C<%INC>, but saves some work of converting Perl module names into package file names and the cryptic use of the C<%INC> vari...

=cut

sub autogenerator_of($) {
    my $class = shift;
    if (blessed $class or (not ref $class and $class =~ /^[:\w]+$/)) {
        $class = shift if $class->isa('Class::AutoGenerate');
    }

view all matches for this distribution

Class-BuildMethods

1 match

lib/Class/BuildMethods.pm view on Meta::CPAN

# on.  Basically, ActiveState's build system does not provide a version of
# Scalar::Util with refaddr, so modules requiring this function cannot build.
# As a result, I'm forced to manually copy it here.
#

sub _refaddr($) {
    my $pkg = ref( $_[0] ) or return undef;
    if ( blessed( $_[0] ) ) {
        bless $_[0], 'Class::BuildMethods::Fake';
    }
    else {

view all matches for this distribution

Class-Closure

1 match

lib/Class/Closure.pm view on Meta::CPAN

		);
	};
	return;
}

sub extends($) { &$EXTENDS }

sub destroy(&) { _install DESTROY => \Class::Closure::DestroyDelegate->new( $_[0] ) }

package Class::Closure::DestroyDelegate;
our $VERSION = '0.304';

sub new { bless $_[1] }

view all matches for this distribution

Class-CompiledC

2 results

our %EXPORT_TAGS;
our @EXPORT_OK;
our $re_ft;
our $re_ft_isa;

sub __circumPrint($$$);
sub __include;
sub __baseref($$);
sub __hashref($);
sub __arrayref($);
sub __coderef($);
sub __fetchSymbolName($);
sub __promoteFieldTypeToMacro($);
sub __parseFieldType;


$re_ft     = qr/^(?:\s*)(int|float|number|string|ref|arrayref|hashref|
                         coderef|object|regexpref|any|uint)(?:\s*)/xi;

Utitlity function, concatenates it's arguments, in the order
C<$_[1].$_[0].$_[1]> and returns the resulting string. Does not print anything.

=cut

sub __circumPrint($$$)
{
        return $_[1].$_[0].$_[2];
}

=head3 __include


Determines if REFERENCE is actually a reference and and is of type TYPE.

=cut

sub __baseref($$)
{
        defined $_[0] && ref $_[0] && ref $_[0] eq $_[1];
}

=head3 __hashref

Determines if REFERENCE is actually a hash reference.
Utitlizes C<__baseref>.

=cut

sub __hashref($)
{
        __baseref $_[0], 'HASH';
}

=head3 __arrayref

Determines if REFERENCE is actually a array reference.
Utitlizes C<__baseref>.

=cut

sub __arrayref($)
{
        __baseref $_[0], 'ARRAY';
}

=head3 __coderef

Determines if REFERENCE is actually a code reference.
Utitlizes C<__baseref>.

=cut

sub __coderef($)
{
        __baseref($_[0], 'CODE')
}

=head3 __fetchSymbolName

Returns the Symbol name from the glob reference GLOBREF.
Croaks if GLOBREF acutally isn't a glob reference.

=cut

sub __fetchSymbolName($)
{
        no strict 'refs';
        my $symbol = shift;

        __baseref $symbol, 'GLOB' or croak 'not a GLOB reference';

Takes a fieldtype specfication, and returns a C<C> macro for doing the test.
Does not handle parametric types like C<isa>. See C<__parseFieldType> for that.

=cut

sub __promoteFieldTypeToMacro($)
{
        my $type = shift;

        return '' unless ($type);
        return '' if     ($type =~ /^any$/i);

view all matches for this distribution

Class-Component

1 match

inc/Test/More.pm view on Meta::CPAN

}


#line 425

sub cmp_ok($$$;$) {
    my $tb = Test::More->builder;

    $tb->cmp_ok(@_);
}

view all matches for this distribution

Class-Constructor

1 match

t/lib/Test/More.pm view on Meta::CPAN


    cmp_ok( $big_hairy_number, '==', $another_big_hairy_number );

=cut

sub cmp_ok($$$;$) {
    $Test->cmp_ok(@_);
}


=item B<can_ok>

view all matches for this distribution

Class-Contract

3 results

  my $class = shift;
  my $caller = caller;
  $contract{$caller}{use_old} = 0  if grep /^old$/, @_; 
}

sub contract(&) {  $_[0]->();  _build_class(caller) }

sub check(\%;$) {
# NOT IN PRODUCTION...
  my $state = !$#_ ? 0 : $_[1] ? 1 : 0;
  defined $_
    or croak("Usage:\n\tcheck \%sentinel",
       ($#_ ? " => $state" : ""),

    unless $current->{'gentype'} =~ /\A(SCALAR|ARRAY|HASH)\z/;
  # ...NOT IN PRODUCTION
  return $current;
}

sub attr($;$) { _member('attr'   => @_) }
sub method($) { _member('method' => @_) }
sub ctor(;$)  { _member('ctor'   => @_) }
sub dtor()    { _member('dtor') }
sub clon()    { _member('clone') }

sub scalar_attrs(@) { map _member('attr', $_, 'SCALAR'), @_ }
sub array_attrs(@)  { map _member('attr', $_, 'ARRAY'),  @_ }
sub hash_attrs(@)   { map _member('attr', $_, 'HASH'),   @_ }
sub methods(@)      { map _member('attr', $_),           @_ }

sub class(@)    { $_->{'shared'}   = 1  foreach(@_); @_ }
sub abstract(@) { $_->{'abstract'} = 1  foreach(@_); @_ }
sub private(@)  { $_->{'private'}  = 1  foreach(@_); @_ }

my %def_msg = (
  'pre'   => 'Pre-condition at %s failed',
  'post'  => 'Post-condition at %s failed',
  'invar' => 'Class invariant at %s failed',

sub failmsg {
  croak "Unattached failmsg"  unless $msg_target;
  $msg_target->{'msg'} = shift;
}

sub pre(&)  { _current('pre'  => @_) }
sub post(&) { _current('post' => @_) }
sub impl(&) { _current('impl' => @_) }

sub optional { # my (@descriptors) = @_;
  $_->{'opt'} = 1  foreach(@_); @_ # NOT IN PRODUCTION
}

sub invar(&) {
  my ($code) = @_;

  my $descriptor = {
    'code'  => $code,
    'opt'   => 0,    # NOT IN PRODUCTION

  push @{$contract{$descriptor->{'owner'}}{'invar'}}, $descriptor;
  $msg_target = $descriptor;
}


sub inherits(@)  {
  my ($owner) = _location;
  foreach (@_) {
    croak "Can't create circular reference in inheritence\n$_ is a(n) $owner" 
      if $_->isa($owner)
  }
  push @{$contract{$owner}{'parents'}}, @_;
}

sub _build_class($) {
  my ($class) = @_;
  my $spec = $contract{$class};
  _inheritance($class, $spec);
  _attributes($class, $spec);
  _methods($class, $spec);

view all matches for this distribution

Class-DBI-Audit

1 match

t/01-artist.t view on Meta::CPAN


$ENV{REMOTE_USER} = 'jennifer_lopez123';
$ENV{REQUEST_URI}  = '/register';
$ENV{REMOTE_ADDR} = '000.000.000';

sub do_transaction(&) {
    my $sub = shift;
    Artist->db_Main->begin_work;
    $sub->();
    Artist->db_Main->commit;
}

view all matches for this distribution

Class-Data-ConfigHash

1 match

inc/Test/More.pm view on Meta::CPAN

}


#line 424

sub cmp_ok($$$;$) {
    my $tb = Test::More->builder;

    $tb->cmp_ok(@_);
}

view all matches for this distribution

Class-Declare

2 results

Declare.pm view on Meta::CPAN

to the current package version (or revision, if B<VERSION()> falls back to
B<REVISION()>). B<VERSION()> will die if I<required> is not a valid version
string.

=cut
sub VERSION(;$)
{
  my  $self       = __PACKAGE__->class( shift );

  # extract the package version (if it exists)
  #   - fallback to the REVISION if there's no version

view all matches for this distribution

Class-Discover

1 match

t/simple.t view on Meta::CPAN

    my @m = keys %{ $x };
    my @n = keys %{ $y };
    return $m[0] cmp $n[0];
}

sub c_sort($){
    [ sort { class_sort($a,$b) } @{ $_[0] } ]
}

sub make_paths_native {
    my ( $result_list ) = @_;

view all matches for this distribution

Class-Framework

3 results

lib/Class/Framework.pm view on Meta::CPAN

use Class::Accessor ();
use Class::MethodVars ();

our $VERSION = '1.'.qw $Rev: 228 $[1];

sub insert_base($$) {
	my ($package,$base) = @_;
	eval "unshift(\@${package}::ISA,q($base))" unless $package->isa($base);
}

sub add_base($@) {
	my ($package,@base) = @_;
	eval "package $package; use base qw( @base ); 1" or die $@;
}

sub import {

view all matches for this distribution

Class-Generate

5 results

    'Class::Generate::Array_Class' => 'ARRAY',
    'Class::Generate::Hash_Class'  => 'HASH'
);
my %warnings_keys = map( ( $_ => 1 ), qw(use no register) );

sub class(%)
{    # One of the three interface
    my %params = @_;    # routines to the package.
    if ( defined $params{-parent} )
    {                   # Defines a class or a
        subclass(@_);    # subclass.

        if !$allow_redefine_for_class && &$class_defined($class_name);
    &$set_class_type( $params{$class_name} );
    &$process_class( $params{$class_name} );
}

sub subclass(%)
{    # One of the three interface
    my %params = @_;    # routines to the package.
    &$initialize();     # Defines a subclass.
    my ( $p_spec, $parent );
    if ( defined( $p_spec = $params{-parent} ) )

        $class->add_parents( Class::Generate::Class_Holder::get($p) );
    }
    &$process_class( $params{$class_name} );
}

sub delete_class(@)
{    # One of the three interface routines
    for my $class (@_)
    {    # to the package.  Deletes a class
        next if !eval '%' . $class . '::';    # declared using Class::Generate.
        if ( !eval '%' . $class . '::_cginfo' )

use strict;    # related to storing and retrieving
               # information on classes.  It lets classes
               # saved in files be reused transparently.
my %classes;

sub store($)
{    # Given a class, store it so it's
    my $class = $_[0];                    # accessible in future invocations of
    $classes{ $class->name } = $class;    # class() and subclass().
}

# we check to see if the variable %<class_name>::_cginfo exists (see
# form(), below); if it does, we use the information it contains to
# create an instance of Class::Generate::Class.  If %<class_name>::_cginfo
# doesn't exist, the package wasn't created by Class::Generate.  We try
# to infer some characteristics of the class.
sub get($;$)
{
    my ( $class_name, $default_type ) = @_;
    return $classes{$class_name} if exists $classes{$class_name};

    return undef if !eval '%' . $class_name . '::';    # Package doesn't exist.


    $classes{$class_name} = $class;
    return $class;
}

sub remove($)
{
    delete $classes{ $_[0] };
}

sub form($)
{
    my $class = $_[0];
    my $form  = qq|use vars qw(\%_cginfo);\n| . '%_cginfo = (';
    if ( $class->isa('Class::Generate::Array_Class') )
    {

    }
    $form .= ');' . "\n";
    return $form;
}

sub member($)
{
    my $member = $_[0];
    my $base;
    my $form = $member->name . ' => {';
    $form .= " type => '"

        $form .= ", base => '$base'";
    }
    return $form . '}';
}

sub list_of_values($@)
{
    my ( $key, @list ) = @_;
    return '' if !@list;
    return "$key => [" . join( ', ', map( "'$_'", @list ) ) . ']';
}

sub comma_prefixed_list_of_values($@)
{
    return $#_ > 0 ? ', ' . list_of_values( $_[0], @_[ 1 .. $#_ ] ) : '';
}

package Class::Generate::Member_Names;    # This package encapsulates functions

    $nonpublic_member_regexp
    , # (For class methods) Regexp of accessors for protected and private members.
    $private_class_methods_regexp
);    # (Ditto) Regexp of private class methods.

sub accessible_member_regexps($;$);
sub accessible_members($;$);
sub accessible_accessor_regexps($;$);
sub accessible_user_defined_method_regexps($;$);
sub class_of($$;$);
sub member_index($$);

sub set_element_regexps()
{    # Establish the regexps for
    my @names;    # name substitution.

    # First for members...
    @names = accessible_member_regexps($class);

    {
        undef $private_class_methods_regexp;
    }
}

sub substituted($)
{    # Within a code fragment, replace
    my $code = $_[0];    # member names and accessors with the
                         # appropriate forms.
    $code =~ s/$member_regexp/member_invocation($1, $&)/eg
        if defined $member_regexp;

        if defined $private_class_methods_regexp;
    return $code;
}

# Perform the actual substitution
sub member_invocation($$)
{    # for member references.
    my ( $member_reference, $match ) = @_;
    my ( $name, $type, $form, $index );
    return $member_reference
        if $match =~ /\A(?:my|local)\b[^=;()]+$member_reference$/s;

    $form = $class->instance_var . '->' . $index;
    return $type eq '$' ? $form : $type . '{' . $form . '}';
}

# Perform the actual substitution for
sub accessor_invocation($$$)
{    # accessor and user-defined method references.
    my ( $accessor_name, $element_name, $match ) = @_;
    my $prefix = $class->instance_var . '->';
    my $c      = class_of( $element_name, $class );
    if ( !( $c->protected($element_name) || $c->private($element_name) ) )

        $form .= ')';
    }
    return $form;
}

sub member_index($$)
{
    my ( $class, $member_name ) = @_;
    return $class->index($member_name) if defined $class->members($member_name);
    for my $parent ( grep ref $_, $class->parents )
    {

        return $index if defined $index;
    }
    return undef;
}

sub accessible_member_regexps($;$)
{
    my ( $class, $disallow_private_members ) = @_;
    my @members;
    if ($disallow_private_members)
    {

        map( accessible_member_regexps( $_, 1 ),
            grep( ref $_, $class->parents ) )
    );
}

sub accessible_members($;$)
{
    my ( $class, $disallow_private_members ) = @_;
    my @members;
    if ($disallow_private_members)
    {

    }
    return ( @members,
        map( accessible_members( $_, 1 ), grep( ref $_, $class->parents ) ) );
}

sub accessible_accessor_regexps($;$)
{
    my ( $class, $disallow_private_members ) = @_;
    my ( $member_name, @accessor_names );
    for my $member ( $class->members_values )
    {

        map( accessible_accessor_regexps( $_, 1 ),
            grep( ref $_, $class->parents ) )
    );
}

sub accessible_user_defined_method_regexps($;$)
{
    my ( $class, $disallow_private_methods ) = @_;
    return (
        (
            $disallow_private_methods

            grep( ref $_, $class->parents ) )
    );
}

# Given element E and class C, return C if E is an
sub class_of($$;$)
{    # element of C; if not, search parents recursively.
    my ( $element_name, $class, $disallow_private_members ) = @_;
    return $class
        if ( defined $class->members($element_name)
        || defined $class->user_defined_methods($element_name) )


my $package_decl;
my $member_error_message = '%s, member "%s": In "%s" code: %s';
my $method_error_message = '%s, method "%s": %s';

sub create_code_checking_package($);
sub fragment_as_sub($$\@;\@);
sub collect_code_problems($$$$@);

# Check each user-defined code fragment in $class for errors. This includes
# pre, post, and assert code, as well as user-defined methods.  Set
# $errors_found according to whether errors (not warnings) were found.
sub check_user_defined_code($$$$)
{
    my ( $class, $class_name_label, $warnings, $errors ) = @_;
    my ( $code, $instance_var, @valid_variables, @class_vars, $w, $e, @members,
        $problems_in_pre, %seen );
    create_code_checking_package $class;

        collect_code_problems $code, $warnings, $errors, $method_error_message,
            $class_name_label, $method->name;
    }
}

sub create_code_checking_package($)
{    # Each class with user-defined code gets
    my $class = $_[0];    # its own package in which that code is
                          # evaluated.  Create said package.
    $package_decl = 'package ' . __PACKAGE__ . '::check::' . $class->name . ";";
    $package_decl .= 'use strict;' if $class->strict;

    $packages .= 'use vars qw(@ISA);' if $class->parents;
    eval $package_decl . $packages;
}

# Evaluate a code fragment, passing on
sub collect_code_problems($$$$@)
{    # warnings and errors.
    my ( $code_form, $warnings, $errors, $error_message, @params ) = @_;
    my @warnings;
    local $SIG{__WARN__} = sub { push @warnings, $_[0] };
    local $SIG{__DIE__};

    my ( $message, $error, @params ) = @_;          # a little by removing the
    $error =~ s/\(eval \d+\) //g;                   # "(eval N)" forms that perl
    return sprintf( $message, @params, $error );    # inserts.
}

sub fragment_as_sub($$\@;\@)
{
    my ( $code, $id_var, $class_vars, $valid_vars ) = @_;
    my $form;
    $form = "sub{my $id_var;";
    if ( $#$class_vars >= 0 )

    return undef;
}

my %map = ( '@' => 'ARRAY', '%' => 'HASH' );

sub verify_value($$)
{    # Die if a given value (ref or string)
    my ( $value, $type ) = @_;    # is not the specified type.
        # The following code is not wrong, but it could be smarter.
    if ( $type =~ /^\w/ )
    {

view all matches for this distribution

Class-InsideOut

1 match

lib/Class/InsideOut.pm view on Meta::CPAN

    }

    return $self;
}

sub private($\%;$) { ## no critic -- prototype
    &_check_property;
    $_[2] ||= {};
    $_[2] = { %{$_[2]}, privacy => 'private' };
    goto &_install_property;
}

sub property($\%;$) { ## no critic -- prototype
    &_check_property;
    goto &_install_property;
}

sub public($\%;$) { ## no critic -- prototype
    &_check_property;
    $_[2] ||= {};
    $_[2] = { %{$_[2]}, privacy => 'public' };
    goto &_install_property;
}

sub readonly($\%;$) { ## no critic -- prototype
    &_check_property;
    $_[2] ||= {};
    $_[2] = { 
        %{$_[2]}, 
        privacy => 'public',

view all matches for this distribution

Class-Interface

1 match

# some class vars for changing behaviour
$Class::Interface::AUTO_CONSTRUCTOR = 0;
$Class::Interface::CONFESS = 0;

# define a contract
sub error(*);

=pod

=head2 &interface()

Turns the calling class into an interface.

=cut
sub interface() {
  my $caller = caller();

  return if !$caller || $caller eq "main";

  # interfaces should be usable.

=head2 &abstract()

Turns the calling class into an abstract.

=cut
sub abstract() {
  my $caller = caller();

  return if !$caller || $caller eq "main";

  # interfaces should be usable.


If all goes well pushes the name of the interface to the ISA array of
the class.

=cut
sub implements(@) {
  my $caller = caller;

  my %missing;
  foreach my $implements (@_) {
    eval "use $implements;";


If all goes well pushes the name of the abstract class to the ISA
array of the class.

=cut
sub extends(*) {
  my $caller = caller();

  my %missing;
  foreach my $extends (@_) {
    eval "use $extends;";

    };
  }
}

# die
sub error(*) {
  my $strings = join("", @_);

  if ( $Class::Interface::CONFESS == 1 ) {
    confess $strings;
  } else {

view all matches for this distribution

Class-Method-Auto

2 results

lib/Class/Method/Auto.pm view on Meta::CPAN


our $VERSION = "1.00";

use attributes 'get';

sub my_croak($$) {
	my ($package, $method) = @_;
	require Carp;
	Carp::croak "Undefined subroutine &${package}::$method called";
}

view all matches for this distribution

Class-Method-Modifiers-Fast

2 results

    $default_object ||= $default_class->new;
    return $default_object;
}

my $import_called = 0;
sub import() {
    $import_called = 1;
    my $class = (grep /^-base$/i, @_) 
    ? scalar(caller)
    : $_[0];
    if (not defined $default_class) {

        $caller =~ s/.*:://;
        croak "Too late to call $caller()"
    }
}

sub find_my_self() {
    my $self = ref($_[0]) eq $default_class
    ? splice(@_, 0, 1)
    : default_object();
    return $self, @_;
}

sub blocks() {
    (my ($self), @_) = find_my_self(@_);

    croak "Invalid arguments passed to 'blocks'"
      if @_ > 1;
    croak sprintf("'%s' is invalid argument to blocks()", shift(@_))

    }

    return (@blocks);
}

sub next_block() {
    (my ($self), @_) = find_my_self(@_);
    my $list = $self->_next_list;
    if (@$list == 0) {
        $list = [@{$self->block_list}, undef];
        $self->_next_list($list);

        $block->run_filters;
    }
    return $block;
}

sub first_block() {
    (my ($self), @_) = find_my_self(@_);
    $self->_next_list([]);
    $self->next_block;
}

sub filters_delay() {
    (my ($self), @_) = find_my_self(@_);
    $self->_filters_delay(defined $_[0] ? shift : 1);
}

sub no_diag_on_only() {
    (my ($self), @_) = find_my_self(@_);
    $self->_no_diag_on_only(defined $_[0] ? shift : 1);
}

sub delimiters() {
    (my ($self), @_) = find_my_self(@_);
    $self->check_late;
    my ($block_delimiter, $data_delimiter) = @_;
    $block_delimiter ||= $self->block_delim_default;
    $data_delimiter ||= $self->data_delim_default;
    $self->block_delim($block_delimiter);
    $self->data_delim($data_delimiter);
    return $self;
}

sub spec_file() {
    (my ($self), @_) = find_my_self(@_);
    $self->check_late;
    $self->_spec_file(shift);
    return $self;
}

sub spec_string() {
    (my ($self), @_) = find_my_self(@_);
    $self->check_late;
    $self->_spec_string(shift);
    return $self;
}

sub filters() {
    (my ($self), @_) = find_my_self(@_);
    if (ref($_[0]) eq 'HASH') {
        $self->_filters_map(shift);
    }
    else {

        push @$filters, @_;
    }
    return $self;
}

sub filter_arguments() {
    $Test::Base::Filter::arguments;
}

sub have_text_diff {
    eval { require Text::Diff; 1 } &&
        $Text::Diff::VERSION >= 0.35 &&
        $Algorithm::Diff::VERSION >= 1.15;
}

sub is($$;$) {
    (my ($self), @_) = find_my_self(@_);
    my ($actual, $expected, $name) = @_;
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    if ($ENV{TEST_SHOW_NO_DIFFS} or
         not defined $actual or

        ok $actual eq $expected,
           $name . "\n" . Text::Diff::diff(\$expected, \$actual);
    }
}

sub run(&;$) {
    (my ($self), @_) = find_my_self(@_);
    my $callback = shift;
    for my $block (@{$self->block_list}) {
        $block->run_filters unless $block->is_filtered;
        &{$callback}($block);


sub END {
    run_compare() unless $Have_Plan or $DIED or not $import_called;
}

sub run_compare() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    for my $block (@{$self->block_list}) {

            is($block->$x, $block->$y, $block->name ? $block->name : ());
        }
    }
}

sub run_is() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    for my $block (@{$self->block_list}) {

           $block->name ? $block->name : ()
          );
    }
}

sub run_is_deeply() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    for my $block (@{$self->block_list}) {
        next unless exists($block->{$x}) and exists($block->{$y});

           $block->name ? $block->name : ()
          );
    }
}

sub run_like() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    for my $block (@{$self->block_list}) {
        next unless exists($block->{$x}) and defined($y);

             $block->name ? $block->name : ()
            );
    }
}

sub run_unlike() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    for my $block (@{$self->block_list}) {
        next unless exists($block->{$x}) and defined($y);

               $block->name ? $block->name : ()
              );
    }
}

sub skip_all_unless_require() {
    (my ($self), @_) = find_my_self(@_);
    my $module = shift;
    eval "require $module; 1"
        or Test::More::plan(
            skip_all => "$module failed to load"
        );
}

sub is_deep() {
    (my ($self), @_) = find_my_self(@_);
    require Test::Deep;
    Test::Deep::cmp_deeply(@_);
}

sub run_is_deep() {
    (my ($self), @_) = find_my_self(@_);
    $self->_assert_plan;
    my ($x, $y) = $self->_section_names(@_);
    for my $block (@{$self->block_list}) {
        next unless exists($block->{$x}) and exists($block->{$y});

        };
    }
    return $spec;
}

sub _strict_warnings() {
    require Filter::Util::Call;
    my $done = 0;
    Filter::Util::Call::filter_add(
        sub {
            return 0 if $done;

            $done = 1;
        }
    );
}

sub tie_output() {
    my $handle = shift;
    die "No buffer to tie" unless @_;
    tie $handle, 'Test::Base::Handle', $_[0];
}

    $ENV{TEST_SHOW_NO_DIFFS} = 1;
}

package Test::Base::Handle;

sub TIEHANDLE() {
    my $class = shift;
    bless \ $_[0], $class;
}

sub PRINT {


sub AUTOLOAD {
    return;
}

sub block_accessor() {
    my $accessor = shift;
    no strict 'refs';
    return if defined &$accessor;
    *$accessor = sub {
        my $self = shift;

view all matches for this distribution

Class-MethodMaker

1 match