Result:
found more than 230 distributions - search limited to the first 2001 files matching your query
( run in 4.934 )
Abstract-Meta-Class
view release on metacpan or search on metacpan
examples/example1.pl view on Meta::CPAN
has '$.id';
has '$.name';
has '$.password' => (
on_change => sub {
my ($self, $attribute, $scope, $value_ref) = @_;
$$value_ref = sha1_hex($$value_ref);
$self;
}
);
has '$.email' => (
on_change => sub {
my ($self, $attribute, $scope, $value_ref) = @_;
die "invalid email format:" . $$value_ref
unless $$value_ref =~ m/^<?[^@<>]+@[^@.<>]+(?:\.[^@.<>]+)+>?$/;
$self;
}
);
has '$.address';
has '%.roles' ;
sub is_valid_password {
my ($self, $password) = @_;
!! ($self->password eq sha1_hex($password));
}
Ac_me-Local
view release on metacpan or search on metacpan
lib/Ac_me/Local.pm view on Meta::CPAN
=head2 function1
=cut
sub function1 {
}
=head2 function2
=cut
sub function2 {
}
=head1 AUTHOR
Thibault Duponchelle, C<< <thibault.duponchelle at gmail.com> >>
AcePerl
view release on metacpan or search on metacpan
# now completely deprecated and gone
# *find_many = \&fetch_many;
# *models = \&classes;
sub connect {
my $class = shift;
my ($host,$port,$user,$pass,$path,$program,
$objclass,$timeout,$query_timeout,$database,
$server_type,$url,$u,$p,$cache,$other);
$self->_create_cache($cache) if $cache;
$self->name2db("$self",$self);
return $self;
}
sub reopen {
my $self = shift;
return 1 if $self->ping;
my $class = ref($self->{database});
my $database;
if ($self->{path}) {
}
$self->{database} = $database;
1;
}
sub class {
my $self = shift;
my $d = $self->{class};
$self->{class} = shift if @_;
$d;
}
sub class_for {
my $self = shift;
my ($class,$id) = @_;
my $selected_class;
if (my $selector = $self->class) {
unless $selected_class->can('new');
$selected_class;
}
sub process_url {
my $class = shift;
my $url = shift;
my ($host,$port,$user,$pass,$path,$server_type) = ('','','','','','');
if ($url) { # look for host:port
return ($host,$port,$user,$pass,$path,$server_type);
}
# Return the low-level Ace::AceDB object
sub db {
return $_[0]->{'database'};
}
# Fetch a model from the database.
# Since there are limited numbers of models, we cache
# the results internally.
sub model {
my $self = shift;
require Ace::Model;
my $model = shift;
my $break_cycle = shift; # for breaking cycles when following #includes
my $key = join(':',$self,'MODEL',$model);
}
# cached get
# pass "1" for fill to get a full fill
# pass any other true value to get a tag fill
sub get {
my $self = shift;
my ($class,$name,$fill) = @_;
# look in caches first
my $obj = $self->memory_cache_fetch($class=>$name)
# _acedb_get() does the caching
$obj = $self->_acedb_get($class,$name,$fill) or return;
$obj;
}
sub _acedb_get {
my $self = shift;
my ($class,$name,$filltag) = @_;
return unless $self->count($class,$name) >= 1;
#return $self->{class}->new($class,$name,$self,1) unless $filltag;
#### CACHE AND CARRY CODE ####
# Be very careful here. The key used for the memory cache is in the format
# db:class:name, but the key used for the file cache is in the format class:name.
# The difference is that the filecache has a built-in namespace but the memory
# cache doesn't.
sub memory_cache_fetch {
my $self = shift;
my ($class,$name) = @_;
my $key = join ":",$self,$class,$name;
return unless defined $MEMORY_CACHE{$key};
carp "memory_cache hit on $class:$name"
if Ace->debug;
return $MEMORY_CACHE{$key};
}
sub memory_cache_store {
my $self = shift;
croak "Usage: memory_cache_store(\$obj)" unless @_ == 1;
my $obj = shift;
my $key = join ':',$obj->db,$obj->class,$obj->name;
return if exists $MEMORY_CACHE{$key};
carp "memory_cache store on ",$obj->class,":",$obj->name if Ace->debug;
weaken($MEMORY_CACHE{$key} = $obj);
}
sub memory_cache_clear {
my $self = shift;
%MEMORY_CACHE = ();
}
sub memory_cache_delete {
my $package = shift;
my $obj = shift or croak "Usage: memory_cache_delete(\$obj)";
my $key = join ':',$obj->db,$obj->class,$obj->name;
delete $MEMORY_CACHE{$key};
}
# Call as:
# $ace->file_cache_fetch($class=>$id)
sub file_cache_fetch {
my $self = shift;
my ($class,$name) = @_;
my $key = join ':',$class,$name;
my $cache = $self->cache or return;
my $obj = $cache->get($key);
$obj;
}
# call as
# $ace->file_cache_store($obj);
sub file_cache_store {
my $self = shift;
my $obj = shift;
return unless $obj->name;
cluck "NULL OBJECT";
}
$cache->set($key,$obj);
}
sub file_cache_delete {
my $self = shift;
my $obj = shift;
my $key = join ':',$obj->class,$obj->name;
my $cache = $self->cache or return;
#### END: CACHE AND CARRY CODE ####
# Fetch one or a group of objects from the database
sub fetch {
my $self = shift;
my ($class,$pattern,$count,$offset,$query,$filled,$total,$filltag) =
rearrange(['CLASS',['NAME','PATTERN'],'COUNT','OFFSET','QUERY',
['FILL','FILLED'],'TOTAL','FILLTAG'],@_);
}
return wantarray ? @h : $h[0];
}
sub cache {
my $self = shift;
my $d = $self->{filecache};
$self->{filecache} = shift if @_;
$d;
}
sub _create_cache {
my $self = shift;
my $params = shift;
$params = {} if $params and !ref $params;
return unless eval {require Cache::SizeAwareFileCache}; # not installed
my $cache_obj = Cache::SizeAwareFileCache->new(\%cache_params);
$self->cache($cache_obj);
}
# class method
sub name2db {
shift;
my $name = shift;
return unless defined $name;
my $d = $NAME2DB{$name};
# weaken($NAME2DB{$name} = shift) if @_;
$NAME2DB{$name} = shift if @_;
$d;
}
# make a new object using indicated class and name pattern
sub new {
my $self = shift;
my ($class,$pattern) = rearrange([['CLASS'],['NAME','PATTERN']],@_);
croak "You must provide -class and -pattern arguments"
unless $class && $pattern;
# escape % signs in the string
}
$self->fetch($1 => $2);
}
# perform an AQL query
sub aql {
my $self = shift;
my $query = shift;
my $db = $self->db;
my $r = $self->raw_query("aql -j $query");
if ($r =~ /(AQL error.*)/) {
return @r;
}
# Return the contents of a keyset. Pattern matches are allowed, in which case
# the keysets will be merged.
sub keyset {
my $self = shift;
my $pattern = shift;
$self->raw_query (qq{find keyset "$pattern"});
$self->raw_query (qq{follow});
return $self->_list;
#########################################################
# These functions are for low-level (non OO) access only.
# This is for low-level access only.
sub show {
my ($self,$class,$pattern,$tag) = @_;
$Ace::Error = '';
return unless $self->count($class,$pattern);
# if we get here, then we've got some data to return.
return;
}
return grep (!m!^//!,split("\n\n",$result));
}
sub read_object {
my $self = shift;
return unless $self->{database};
my $result;
while ($self->{database}->status == STATUS_PENDING()) {
my $data = $self->{database}->read();
}
return $result;
}
# do a query, and return the result immediately
sub raw_query {
my ($self,$query,$no_alert,$parse) = @_;
$self->_alert_iterators unless $no_alert;
$self->{database}->query($query, $parse ? ACE_PARSE : () );
return $self->read_object;
}
# return the last error
sub error {
my $class = shift;
$Ace::Error = shift() if defined($_[0]);
$Ace::Error=~s/\0//g; # get rid of nulls
return $Ace::Error;
}
# close the database
sub close {
my $self = shift;
$self->raw_query('save') if $self->auto_save;
foreach (keys %{$self->{iterators}}) {
$self->_unregister_iterator($_);
}
delete $self->{database};
}
sub DESTROY {
my $self = shift;
return if caller() =~ /^Cache\:\:/;
warn "$self->DESTROY at ", join ' ',caller() if Ace->debug;
$self->close;
}
#####################################################################
###################### private routines #############################
sub rearrange {
my($order,@param) = @_;
return unless @param;
my %param;
if (ref $param[0] eq 'HASH') {
push (@return_array,\%param) if %param;
return @return_array;
}
# do a query, but don't return the result
sub _query {
my ($self,@query) = @_;
$self->_alert_iterators;
$self->{'database'}->query("@query");
}
# return a portion of the active list
sub _list {
my $self = shift;
my ($count,$offset) = @_;
my (@result);
my $query = 'list -j';
$query .= " -b $offset" if defined $offset;
}
return @result;
}
# return a portion of the active list
sub _fetch {
my $self = shift;
my ($count,$start,$tag) = @_;
my (@result);
$tag = '' unless defined $tag;
my $query = "show -j $tag";
}
}
return wantarray ? @result : $result[0];
}
sub _fetch_chunk {
my $self = shift;
return unless $self->{database}->status == STATUS_PENDING();
my $result = $self->{database}->read();
$result =~ s/\0//g; # get rid of &$#&@!! nulls
my @chunks = split("\n\n",$result);
push(@result,$self->class_for($class,$id)->newFromText($_,$self));
}
return @result;
}
sub _alert_iterators {
my $self = shift;
foreach (keys %{$self->{iterators}}) {
$self->{iterators}{$_}->invalidate if $self->{iterators}{$_};
}
undef $self->{active_list};
}
sub asString {
my $self = shift;
return "tace://$self->{path}" if $self->{'path'};
my $server = $self->db && $self->db->isa('Ace::SocketServer') ? 'sace' : 'rpcace';
return "$server://$self->{host}:$self->{port}" if $self->{'host'};
return ref $self;
}
sub cmp {
my ($self,$arg,$reversed) = @_;
my $cmp;
if (ref($arg) and $arg->isa('Ace')) {
$cmp = $self->asString cmp $arg->asString;
} else {
return $reversed ? -$cmp : $cmp;
}
# Count the objects matching pattern without fetching them.
sub count {
my $self = shift;
my ($class,$pattern,$query) = rearrange(['CLASS',
['NAME','PATTERN'],
'QUERY'],@_);
$Ace::Error = '';
=cut
# -------------------- AUTOLOADED SUBS ------------------
sub debug {
my $package = shift;
my $d = $DEBUG_LEVEL;
$DEBUG_LEVEL = shift if @_;
$d;
}
# Return true if the database is still connected. This is oddly convoluted
# because there are numerous things that can go wrong, including:
# 1. server has gone away
# 2. server has timed out our connection! (grrrrr)
# 3. communications channel contains unread garbage and is in an inconsistent state
sub ping {
my $self = shift;
local($SIG{PIPE})='IGNORE'; # so we don't get a fatal exception during the check
my $result = $self->raw_query('');
return unless $result; # server has gone away
return if $result=~/broken connection|client time out/; # server has timed us out
return unless $self->{database}->status() == STATUS_WAITING(); #communications oddness
return 1;
}
# Get or set the display style for dates
sub date_style {
my $self = shift;
$self->{'date_style'} = $_[0] if defined $_[0];
return $self->{'date_style'};
}
# Get or set whether we retrieve timestamps
sub timestamps {
my $self = shift;
$self->{'timestamps'} = $_[0] if defined $_[0];
return $self->{'timestamps'};
}
# Add one or more objects to the database
sub put {
my $self = shift;
my @objects = @_;
my $count = 0;
$Ace::Error = '';
foreach my $object (@objects) {
}
return $count;
}
# Parse a single object and return the result as an object
sub parse {
my $self = shift;
my $ace_data = shift;
my @lines = split("\n",$ace_data);
foreach (@lines) { s/;/\\;/; } # protect semicolons
my $query = join("; ",@lines);
return $results[0];
}
# Parse a single object as longtext and return the result
# as an object
sub parse_longtext {
my $self = shift;
my ($title,$body) = @_;
my $mm = "parse =
Longtext $title
$body
return $results[0];
}
# Parse a file and return all the results
sub parse_file {
my $self = shift;
my ($file,$keepgoing) = @_;
local(*ACE);
local($/) = ''; # paragraph mode
my(@objects,$errors);
return @objects;
}
# Create a new Ace::Object in the indicated database
# (doesn't actually write into database until you do a commit)
sub new {
my $self = shift;
my ($class,$name) = rearrange([qw/CLASS NAME/],@_);
return if $self->fetch($class,$name);
my $obj = $self->class_for($class,$name)->new($class,$name,$self);
return $obj;
}
# Return the layout, which contains classes that should be displayed
sub layout {
my $self = shift;
my $result = $self->raw_query('layout');
$result=~s{\n(\s*\n|//.*\n|\0)+\Z}{}m; # get rid of extraneous information
$result;
}
# Return a hash of all the classes and the number of objects in each
sub class_count {
my $self = shift;
return $self->raw_query('classes') =~ /^\s+(\S+) (\d+)/gm;
}
# Return a hash of miscellaneous status information from the server
# (to be expanded later)
sub status {
my $self = shift;
my $data = $self->raw_query('status');
study $data;
my %status;
memory => $memory * 1024,
};
return wantarray ? %status : \%status;
}
sub title {
my $self = shift;
my $status= $self->status;
$status->{database}{title};
}
sub version {
my $self = shift;
my $status= $self->status;
$status->{database}{version};
}
sub auto_save {
my $self = shift;
if ($self->db && $self->db->can('auto_save')) {
$self->db->auto_save;
} else {
$self->{'auto_save'} = $_[0] if defined $_[0];
return $self->{'auto_save'};
}
}
# Perform an ace query and return the result
sub find {
my $self = shift;
my ($query,$count,$offset,$filled,$total) = rearrange(['QUERY','COUNT',
'OFFSET',['FILL','FILLED'],'TOTAL'],@_);
$offset += 0;
$query = "find $query" unless $query=~/^find/i;
}
#########################################################
# Grep function returns count in a scalar context, list
# of retrieved objects in a list context.
sub grep {
my $self = shift;
my ($pattern,$count,$offset,$filled,$filltag,$total,$long) =
rearrange(['PATTERN','COUNT','OFFSET',['FILL','FILLED'],'FILLTAG','TOTAL','LONG'],@_);
$offset += 0;
my $grep = defined($long) && $long ? 'LongGrep' : 'grep';
@h = $filled ? $self->_fetch($count,$offset) : $self->_list($count,$offset);
}
@h;
}
sub pick {
my ($self,$class,$item) = @_;
$Ace::Error = '';
# assumption of uniqueness of name is violated by some classes!
# return () unless $self->count($class,$item) == 1;
return unless $self->count($class,$item) >= 1;
return $result[0];
}
# these two only get loaded if the Ace::Freesubs .XS isn't compiled
sub freeprotect {
my $class = shift;
my $text = shift;
$text =~ s/\n/\\n/g;
$text =~ s/\t/\\t/g;
$text =~ s/"/\\"/g;
return qq("$text");
}
sub split {
my $class = shift;
my $text = shift;
$text =~ s/\\n/\n/g;
$text =~ s/\\t/\t/g;
my ($id,$ts);
return ($class,$id) unless $ts;
return ($class,$id,$ts); # return timestamp
}
# Return a list of all the classes known to the server.
sub classes {
my ($self,$invisible) = @_;
my $query = defined($invisible) && $invisible ?
"query find class !buried"
:
"query find class visible AND !buried";
return $self->_list;
}
################## iterators ##################
# Fetch many objects in iterative style
sub fetch_many {
my $self = shift;
my ($class,$pattern,$filled,$query,$chunksize) = rearrange( ['CLASS',
['PATTERN','NAME'],
['FILL','FILLED'],
'QUERY',
}
my $iterator = Ace::Iterator->new($self,$query,$filled,$chunksize);
return $iterator;
}
sub _register_iterator {
my ($self,$iterator) = @_;
$self->{iterators}{$iterator} = $iterator;
}
sub _unregister_iterator {
my ($self,$iterator) = @_;
$self->_restore_iterator($iterator);
delete $self->{iterators}{$iterator};
}
sub _save_iterator {
my $self = shift;
my $iterator = shift;
return unless $self->{iterators}{$iterator};
$self->{iterator_stack} ||= [];
return 1 if grep { $_ eq $iterator } @{$self->{iterator_stack}};
1; # result code -- CHANGE THIS LATER
}
# horrid method that keeps the database's view of
# iterators in synch with our view
sub _restore_iterator {
my $self = shift;
my $iterator = shift;
# no such iterator known, return false
return unless $self->{iterators}{$iterator};
splice(@$list,$i,1); # remove from position
return 1;
}
sub datetime {
my $self = shift;
my $time = shift || time;
my ($sec,$min,$hour,$day,$mon,$year) = localtime($time);
$year += 1900; # avoid Y3K bug
sprintf("%4d-%02d-%02d %02d:%02d:%02d",$year,$mon+1,$day,$hour,$min,$sec);
}
sub date {
my $self = shift;
my $time = shift || time;
my ($sec,$min,$hour,$day,$mon,$year) = localtime($time);
$year += 1900; # avoid Y3K bug
sprintf("%4d-%02d-%02d",$year,$mon+1,$day);
Acme-123
view release on metacpan or search on metacpan
lib/Acme/123.pm view on Meta::CPAN
'sp' => [qw /uno dos tres cuatro cinco seis siete ocho nueve diez/],
'it' => [qw /uno due tre quattro cinque sei sette otto nove dieci/]
);
my @numbers = @{$languages {en}};
sub printnumbers {
foreach (@numbers) {
print "$_ \n";
}
}
sub setLanguage {
my $self = shift;
my $language = shift;
@numbers = @{$languages {$language}};
}
sub getnumbers {
return @numbers;
}
sub new
{
my ($class, %parameters) = @_;
my $self = bless ({}, ref ($class) || $class);
Acme-1337
view release on metacpan or search on metacpan
lib/Acme/L337.pm view on Meta::CPAN
package L337;
use strict;
sub translate($string) {
# Common leet
my $tempstring;
$tempstring =~ "tr/[i,I]/!";
$tempstring =~ "tr/[t,T]/7";
$tempstring =~ "tr/[e,E]/3";
Acme-24
view release on metacpan or search on metacpan
lib/Acme/24.pm view on Meta::CPAN
use XML::RSSLite ();
use constant URL => 'http://www.notrly.com/jackbauer';
# Returns one random fact
sub random_jackbauer_fact
{
my $url = URL;
my $page = LWP::Simple::get($url);
my $fact = '';
lib/Acme/24.pm view on Meta::CPAN
return($fact);
}
# Returns an array of 24 random facts
sub random_jackbauer_facts
{
my @facts = ();
my $url = URL . '/rss.php';
my $tries = 5;
my %seen;
lib/Acme/24.pm view on Meta::CPAN
return(\@facts);
}
# Build a database of Jack Bauer facts
sub collect_facts
{
my($self, $file) = @_;
$file ||= './jackbauer.txt';
my $new_facts = $self->random_jackbauer_facts();
return unless $new_facts;
Acme-2zicon
view release on metacpan or search on metacpan
lib/Acme/2zicon.pm view on Meta::CPAN
TsurumiMoe
OtsukaMiyu
YamatoAo
);
sub new {
my $class = shift;
my $self = bless {members => []}, $class;
$self->_initialize;
return $self;
}
sub members {
my ($self, $type, @members) = @_;
@members = @{$self->{members}} unless @members;
return @members unless $type;
}
sub sort {
my ($self, $type, $order, @members) = @_;
@members = $self->members unless @members;
# order by desc if $order is true
if ($order) {
lib/Acme/2zicon.pm view on Meta::CPAN
else {
return sort {$a->$type <=> $b->$type} @members;
}
}
sub select {
my ($self, $type, $number, $operator, @members) = @_;
$self->_die('invalid operator was passed in')
unless grep {$operator eq $_} qw(== >= <= > <);
@members = $self->members unless @members;
my $compare = eval "(sub { \$number $operator \$_[0] })";
return grep { $compare->($_->$type) } @members;
}
sub _initialize {
my $self = shift;
for my $member (@members) {
my $module_name = 'Acme::2zicon::'.$member;
lib/Acme/2zicon.pm view on Meta::CPAN
}
return 1;
}
sub _die {
my ($self, $message) = @_;
Carp::croak($message);
}
1;
Acme-3mxA
view release on metacpan or search on metacpan
lib/Acme/3mxA.pm view on Meta::CPAN
use utf8;
package Acme::3mxA;
sub import {
Acme::ÇmÉ”A->import;
}
"með blóðnasir"
Acme-6502
view release on metacpan or search on metacpan
inc/MyBuilder.pm view on Meta::CPAN
package MyBuilder;
use base qw( Module::Build );
sub create_build_script {
my ( $self, @args ) = @_;
$self->_auto_mm;
return $self->SUPER::create_build_script( @args );
}
sub _auto_mm {
my $self = shift;
my $mm = $self->meta_merge;
my @meta = qw( homepage bugtracker MailingList repository );
for my $meta ( @meta ) {
next if exists $mm->{resources}{$meta};
inc/MyBuilder.pm view on Meta::CPAN
$mm->{resources}{$meta} = $av if defined $av;
}
$self->meta_merge( $mm );
}
sub _auto_repository {
my $self = shift;
if ( -d '.svn' ) {
my $info = `svn info .`;
return $1 if $info =~ /^URL:\s+(.+)$/m;
}
inc/MyBuilder.pm view on Meta::CPAN
return $url;
}
return;
}
sub _auto_bugtracker {
'http://rt.cpan.org/NoAuth/Bugs.html?Dist=' . shift->dist_name;
}
sub ACTION_testauthor {
my $self = shift;
$self->test_files( 'xt/author' );
$self->ACTION_test;
}
sub ACTION_critic {
exec qw( perlcritic -1 -q -profile perlcriticrc lib/ ), glob 't/*.t';
}
sub ACTION_tags {
exec(
qw(
ctags -f tags --recurse --totals
--exclude=blib
--exclude=.svn
inc/MyBuilder.pm view on Meta::CPAN
t/ lib/
)
);
}
sub ACTION_tidy {
my $self = shift;
my @extra = qw( Build.PL );
my %found_files = map { %$_ } $self->find_pm_files,
Acme-ADEAS-Utils
view release on metacpan or search on metacpan
lib/Acme/ADEAS/Utils.pm view on Meta::CPAN
Accepts a list, returns the sum of the numbers provided. Anything
that isn't a number will be treated as zero.
=cut
sub sum {
my $sum = 0;
foreach my $element ( @_ ) {
# I could get a module to do this check, but I don't want to
Acme-ALEXEY-Utils
view release on metacpan or search on metacpan
lib/Acme/ALEXEY/Utils.pm view on Meta::CPAN
=head2 sum
=cut
sub sum {
my $sum;
$sum += $_ for @_;
$sum;
}
Acme-APHILIPP-Utils
view release on metacpan or search on metacpan
lib/Acme/APHILIPP/Utils.pm view on Meta::CPAN
Returns the sum of the numbers passed to it, ignoring arguments
that don't look like numbers.
=cut
sub sum {
my $sum;
foreach my $num ( grep { /\A-?\d+\.*\d*\z/ } @_ ) {
$sum += $num;
}
$sum;
Acme-ARUHI-Utils
view release on metacpan or search on metacpan
lib/Acme/ARUHI/Utils.pm view on Meta::CPAN
=head2 sum
=cut
sub sum {
my $sum;
for (grep /^\d+$/, @_) { $sum += $_ }
$sum;
}
Acme-AXP-Utils
view release on metacpan or search on metacpan
lib/Acme/AXP/Utils.pm view on Meta::CPAN
Add a bunch of numbers. Definitely don't multiply them.
=cut
sub sum {
my $tot = 0;
$tot += $_ foreach ( @_ );
return $tot;
}
Acme-AbhiIsNot
view release on metacpan or search on metacpan
lib/Acme/AbhiIsNot.pm view on Meta::CPAN
Returns the sime of the numbers.
=cut
sub sum {
my $sum = 0;
foreach (@_) {
$sum += $_;
}
return $sum;
lib/Acme/AbhiIsNot.pm view on Meta::CPAN
=head2 function2
=cut
sub function2 {
}
=head1 AUTHOR
"abhishek", C<< <"abhishekisnot at gmail.com"> >>
Acme-Acotie
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
use Cwd ();
use File::Find ();
use File::Path ();
use FindBin;
sub autoload {
my $self = shift;
my $who = $self->_caller;
my $cwd = Cwd::cwd();
my $sym = "${who}::AUTOLOAD";
$sym->{$cwd} = sub {
my $pwd = Cwd::cwd();
if ( my $code = $sym->{$pwd} ) {
# delegate back to parent dirs
goto &$code unless $cwd eq $pwd;
}
inc/Module/Install.pm view on Meta::CPAN
unshift @_, ( $self, $1 );
goto &{$self->can('call')} unless uc($1) eq $1;
};
}
sub import {
my $class = shift;
my $self = $class->new(@_);
my $who = $self->_caller;
unless ( -f $self->{file} ) {
inc/Module/Install.pm view on Meta::CPAN
delete $INC{"$self->{path}.pm"};
return 1;
}
sub preload {
my $self = shift;
unless ( $self->{extensions} ) {
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
);
inc/Module/Install.pm view on Meta::CPAN
}
}
my $who = $self->_caller;
foreach my $name ( sort keys %seen ) {
*{"${who}::$name"} = sub {
${"${who}::AUTOLOAD"} = "${who}::$name";
goto &{"${who}::AUTOLOAD"};
};
}
}
sub new {
my ($class, %args) = @_;
# ignore the prefix on extension modules built from top level.
my $base_path = Cwd::abs_path($FindBin::Bin);
unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) {
inc/Module/Install.pm view on Meta::CPAN
$args{wrote} = 0;
bless( \%args, $class );
}
sub call {
my ($self, $method) = @_;
my $obj = $self->load($method) or return;
splice(@_, 0, 2, $obj);
goto &{$obj->can($method)};
}
sub load {
my ($self, $method) = @_;
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
) unless $self->{extensions};
inc/Module/Install.pm view on Meta::CPAN
push @{$self->{extensions}}, $obj;
$obj;
}
sub load_extensions {
my ($self, $path, $top) = @_;
unless ( grep { lc $_ eq lc $self->{prefix} } @INC ) {
unshift @INC, $self->{prefix};
}
inc/Module/Install.pm view on Meta::CPAN
}
$self->{extensions} ||= [];
}
sub find_extensions {
my ($self, $path) = @_;
my @found;
File::Find::find( sub {
my $file = $File::Find::name;
return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
my $subpath = $1;
return if lc($subpath) eq lc($self->{dispatch});
inc/Module/Install.pm view on Meta::CPAN
#####################################################################
# Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
}
return $call;
}
sub _read {
local *FH;
open FH, "< $_[0]" or die "open($_[0]): $!";
my $str = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $str;
}
sub _write {
local *FH;
open FH, "> $_[0]" or die "open($_[0]): $!";
foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!" }
close FH or die "close($_[0]): $!";
}
sub _version ($) {
my $s = shift || 0;
$s =~ s/^(\d+)\.?//;
my $l = $1 || 0;
my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
}
# Cloned from Params::Util::_CLASS
sub _CLASS ($) {
(
defined $_[0]
and
! ref $_[0]
and
Acme-Addslashes
view release on metacpan or search on metacpan
lib/Acme/Addslashes.pm view on Meta::CPAN
enough slashes added to make Freddy Krueger jealous.
=cut
# The addslashes function. It is documented above. -- JAITKEN
sub addslashes {
# Get the arguments passed to the function using the shift command -- JAITKEN
my $unsafe_string = shift;
# Split the string into letters - just like explode in PHP. Or maybe str_split
# I can't remember which one is which -- JAITKEN
Acme-Affinity
view release on metacpan or search on metacpan
lib/Acme/Affinity.pm view on Meta::CPAN
use namespace::clean;
has questions => (
is => 'ro',
isa => sub { die 'Not an ArrayRef' unless ref($_[0]) eq 'ARRAY' },
default => sub { [] },
required => 1,
);
has importance => (
is => 'ro',
isa => sub { die 'Not a HashRef' unless ref($_[0]) eq 'HASH' },
default => sub {
{
'irrelevant' => 0,
'a little important' => 1,
'somewhat important' => 10,
'very important' => 50,
lib/Acme/Affinity.pm view on Meta::CPAN
);
has me => (
is => 'ro',
isa => sub { die 'Not an ArrayRef' unless ref($_[0]) eq 'ARRAY' },
default => sub { [] },
required => 1,
);
has you => (
is => 'ro',
isa => sub { die 'Not an ArrayRef' unless ref($_[0]) eq 'ARRAY' },
default => sub { [] },
required => 1,
);
sub score {
my $self = shift;
my $me_score = _score( $self->me, $self->you, $self->importance );
my $you_score = _score( $self->you, $self->me, $self->importance );
lib/Acme/Affinity.pm view on Meta::CPAN
my $score = $product->broot($question_count);
return $score->numify * 100;
}
sub _score {
my ( $me, $you, $importance ) = @_;
my $score = 0;
my $total = 0;
Acme-Aheui
view release on metacpan or search on metacpan
lib/Acme/Aheui.pm view on Meta::CPAN
This method will create and return C<Acme::Aheui> object.
=cut
sub new {
my $class = shift;
my %args = @_;
my $source = $args{source} || '';
my $encoding = $args{output_encoding} || Term::Encoding::get_encoding();
lib/Acme/Aheui.pm view on Meta::CPAN
bless $self, $class;
return $self;
}
sub build_codespace {
my ($source) = @_;
my @lines = split /\r?\n/, $source;
my @rows = ();
for my $line (@lines) {
lib/Acme/Aheui.pm view on Meta::CPAN
push @rows, \@row;
}
return \@rows;
}
sub disassemble_hangul_char {
my ($char) = @_;
if ($char =~ /[가-힣]/) {
my $code = unpack 'U', $char;
$code -= 0xAC00;
lib/Acme/Aheui.pm view on Meta::CPAN
This method will execute the aheui program and return the exit code.
It may use C<STDIN> and/or C<STDOUT> if the aheui program uses I/O.
=cut
sub execute {
my ($self) = @_;
return 0 unless $self->_has_initial_command();
return $self->_loop_steps();
}
sub _has_initial_command {
my ($self) = @_;
for my $row (@{ $self->{_codespace} }) {
my $first_command = @$row[0];
if ($first_command && $$first_command{cho} != -1) {
lib/Acme/Aheui.pm view on Meta::CPAN
}
}
return 0;
}
sub _loop_steps {
my ($self) = @_;
while (1) {
my $codespace = $self->{_codespace};
my ($x, $y) = ($self->{_x}, $self->{_y});
lib/Acme/Aheui.pm view on Meta::CPAN
$self->_move_cursor();
}
}
sub _move_cursor {
my ($self) = @_;
my $codespace = $self->{_codespace};
$self->{_x} += $self->{_dx};
$self->{_y} += $self->{_dy};
lib/Acme/Aheui.pm view on Meta::CPAN
$self->{_dx} != 0) {
$self->{_x} = 0;
}
}
sub _get_deltas_upon_jung {
my ($self, $jung) = @_;
my $dx = $self->{_dx};
my $dy = $self->{_dy};
lib/Acme/Aheui.pm view on Meta::CPAN
else {
return ($dx, $dy);
}
}
sub _push {
my ($self, $i, $n) = @_;
if ($i == 27) { # ã…Ž
return;
}
else {
push @{$self->{_stacks}->[$i]}, $n;
}
}
sub _pop {
my ($self, $i) = @_;
my $stack = $self->{_stacks}->[$i];
if ($i == 21) { # ã…‡
return shift @$stack;
lib/Acme/Aheui.pm view on Meta::CPAN
else {
return pop @$stack;
}
}
sub _duplicate {
my ($self, $i) = @_;
my $stack = $self->{_stacks}->[$i];
if ($i == 21) { # ã…‡
my $first = $$stack[0];
lib/Acme/Aheui.pm view on Meta::CPAN
my $last = $$stack[-1];
push @$stack, $last;
}
}
sub _swap {
my ($self, $i) = @_;
my $stack = $self->{_stacks}->[$i];
if ($i == 21) { # ã…‡
my $first = $$stack[0];
lib/Acme/Aheui.pm view on Meta::CPAN
$$stack[-1] = $next;
$$stack[-2] = $last;
}
}
sub _output_number {
my ($self, $number) = @_;
print $number;
}
sub _output_code_as_character {
my ($self, $code) = @_;
my $unichar = pack 'U', $code;
print encode($self->{_encoding}, $unichar);
}
sub _get_input_character_as_code {
my ($self) = @_;
my $char = ReadKey(0);
return unpack 'U', $char;
}
sub _get_input_number {
my ($self) = @_;
return int(ReadLine(0));
}
Acme-AirRead
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
*inc::Module::Install::VERSION = *VERSION;
@inc::Module::Install::ISA = __PACKAGE__;
}
sub import {
my $class = shift;
my $self = $class->new(@_);
my $who = $self->_caller;
#-------------------------------------------------------------
inc/Module/Install.pm view on Meta::CPAN
$MAIN = $self;
return 1;
}
sub autoload {
my $self = shift;
my $who = $self->_caller;
my $cwd = Cwd::cwd();
my $sym = "${who}::AUTOLOAD";
$sym->{$cwd} = sub {
my $pwd = Cwd::cwd();
if ( my $code = $sym->{$pwd} ) {
# Delegate back to parent dirs
goto &$code unless $cwd eq $pwd;
}
inc/Module/Install.pm view on Meta::CPAN
unshift @_, ( $self, $1 );
goto &{$self->can('call')};
};
}
sub preload {
my $self = shift;
unless ( $self->{extensions} ) {
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
);
inc/Module/Install.pm view on Meta::CPAN
}
my $who = $self->_caller;
foreach my $name ( sort keys %seen ) {
local $^W;
*{"${who}::$name"} = sub {
${"${who}::AUTOLOAD"} = "${who}::$name";
goto &{"${who}::AUTOLOAD"};
};
}
}
sub new {
my ($class, %args) = @_;
delete $INC{'FindBin.pm'};
{
# to suppress the redefine warning
local $SIG{__WARN__} = sub {};
require FindBin;
}
# ignore the prefix on extension modules built from top level.
my $base_path = Cwd::abs_path($FindBin::Bin);
inc/Module/Install.pm view on Meta::CPAN
$args{wrote} = 0;
bless( \%args, $class );
}
sub call {
my ($self, $method) = @_;
my $obj = $self->load($method) or return;
splice(@_, 0, 2, $obj);
goto &{$obj->can($method)};
}
sub load {
my ($self, $method) = @_;
$self->load_extensions(
"$self->{prefix}/$self->{path}", $self
) unless $self->{extensions};
inc/Module/Install.pm view on Meta::CPAN
push @{$self->{extensions}}, $obj;
$obj;
}
sub load_extensions {
my ($self, $path, $top) = @_;
my $should_reload = 0;
unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) {
unshift @INC, $self->{prefix};
inc/Module/Install.pm view on Meta::CPAN
}
$self->{extensions} ||= [];
}
sub find_extensions {
my ($self, $path) = @_;
my @found;
File::Find::find( sub {
my $file = $File::Find::name;
return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is;
my $subpath = $1;
return if lc($subpath) eq lc($self->{dispatch});
inc/Module/Install.pm view on Meta::CPAN
#####################################################################
# Common Utility Functions
sub _caller {
my $depth = 0;
my $call = caller($depth);
while ( $call eq __PACKAGE__ ) {
$depth++;
$call = caller($depth);
inc/Module/Install.pm view on Meta::CPAN
return $call;
}
# Done in evals to avoid confusing Perl::MinimumVersion
eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _read {
local *FH;
open( FH, '<', $_[0] ) or die "open($_[0]): $!";
my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $string;
}
END_NEW
sub _read {
local *FH;
open( FH, "< $_[0]" ) or die "open($_[0]): $!";
my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $string;
}
END_OLD
sub _readperl {
my $string = Module::Install::_read($_[0]);
$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
$string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s;
$string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg;
return $string;
}
sub _readpod {
my $string = Module::Install::_read($_[0]);
$string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg;
return $string if $_[0] =~ /\.pod\z/;
$string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg;
$string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg;
inc/Module/Install.pm view on Meta::CPAN
return $string;
}
# Done in evals to avoid confusing Perl::MinimumVersion
eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _write {
local *FH;
open( FH, '>', $_[0] ) or die "open($_[0]): $!";
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
}
close FH or die "close($_[0]): $!";
}
END_NEW
sub _write {
local *FH;
open( FH, "> $_[0]" ) or die "open($_[0]): $!";
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
}
inc/Module/Install.pm view on Meta::CPAN
}
END_OLD
# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
sub _version ($) {
my $s = shift || 0;
my $d =()= $s =~ /(\.)/g;
if ( $d >= 2 ) {
# Normalise multipart versions
$s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
inc/Module/Install.pm view on Meta::CPAN
} $s =~ /(\d{1,3})\D?/g;
$l = $l . '.' . join '', @v if @v;
return $l + 0;
}
sub _cmp ($$) {
_version($_[1]) <=> _version($_[2]);
}
# Cloned from Params::Util::_CLASS
sub _CLASS ($) {
(
defined $_[0]
and
! ref $_[0]
and
( run in 4.934 seconds using v1.01-cache-2.11-cpan-3b040b67cf0 )