Result:
found more than 563 distributions - search limited to the first 2001 files matching your query
( run in 0.525 )
Acme-Test-Weather
view release on metacpan or search on metacpan
CPAN/MakeMaker.pm view on Meta::CPAN
$NAME = $1;
}
last;
}
}
die <<END unless length($NAME);
Can't determine a NAME for this distribution.
Please pass a NAME parameter to the WriteMakefile function in Makefile.PL.
END
return $NAME;
}
sub find_files {
my ($file, $path) = @_;
$path = '' if not defined $path;
$file = "$path/$file" if length($path);
if (-f $file) {
return ($file);
}
elsif (-d $file) {
my @files = ();
CPAN/MakeMaker.pm view on Meta::CPAN
eval {
$VERSION = ExtUtils::MM_Unix->parse_version($modules[0]);
};
print STDERR $@ if $@;
}
die <<END unless length($VERSION);
Can't determine a VERSION for this distribution.
Please pass a VERSION parameter to the WriteMakefile function in Makefile.PL.
END
return $VERSION;
}
CPAN/MakeMaker.pm view on Meta::CPAN
}
for (find_files('CPAN')) {
my $filepath = $_;
$filepath = "$relative_path/$filepath"
if length($relative_path);
unless (defined $manifest{$filepath}) {
PRINT 'Updating your MANIFEST file:'
unless $manifest_changed++;
PRINT " Adding '$filepath'";
push @$manifest, "$filepath\n";
CPAN/MakeMaker.pm view on Meta::CPAN
$manifest_path = $path;
last;
}
unshift @relative_dirs, pop(@cwd_dirs);
}
unless (length($manifest_path)) {
die "Can't locate the MANIFEST file for '$cwd'\n";
}
$relative_path = join '/', @relative_dirs
if @relative_dirs;
Acme-TestDist-Cpp-EUMM-EUCppGuess
view release on metacpan or search on metacpan
mg_findext|5.013008||pn
mg_find|||n
mg_free_type||5.013006|
mg_free|||
mg_get|||
mg_length||5.005000|
mg_localize|||
mg_magical|||n
mg_set|||
mg_size||5.005000|
mini_mktime||5.007002|n
reg_named_buff_nextkey||5.009005|
reg_named_buff_scalar||5.009005|
reg_named_buff|||
reg_node|||
reg_numbered_buff_fetch|||
reg_numbered_buff_length|||
reg_numbered_buff_store|||
reg_qr_package|||
reg_recode|||
reg_scan_name|||
reg_skipcomment|||n
utf16_textfilter|||
utf16_to_utf8_reversed||5.006001|
utf16_to_utf8||5.006001|
utf8_distance||5.006000|
utf8_hop||5.006000|n
utf8_length||5.007001|
utf8_mg_len_cache_update|||
utf8_mg_pos_cache_update|||
utf8_to_bytes||5.006001|
utf8_to_uvchr_buf||5.015009|
utf8_to_uvchr||5.007001|
if (exists $opt{'list-unsupported'}) {
my $f;
for $f (sort { lc $a cmp lc $b } keys %API) {
next unless $API{$f}{todo};
print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n";
}
exit 0;
}
# Scan for possible replacement candidates
#ifndef ERRSV
# define ERRSV get_sv("@",FALSE)
#endif
/* Hint: gv_stashpvn
* This function's backport doesn't support the length parameter, but
* rather ignores it. Portability can only be ensured if the length
* parameter is used for speed reasons, but the length can always be
* correctly computed from the string argument.
*/
#ifndef gv_stashpvn
# define gv_stashpvn(str,len,create) gv_stashpv(str,create)
#endif
#if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL)
Size_t
DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size)
{
Size_t used, length, copy;
used = strlen(dst);
length = strlen(src);
if (size > 0 && used < size - 1) {
copy = (length >= size - used) ? size - used - 1 : length;
memcpy(dst + used, src, copy);
dst[used + copy] = '\0';
}
return used + length;
}
#endif
#endif
#if !defined(my_strlcpy)
#if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL)
Size_t
DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size)
{
Size_t length, copy;
length = strlen(src);
if (size > 0) {
copy = (length >= size) ? size - 1 : length;
memcpy(dst, src, copy);
dst[copy] = '\0';
}
return length;
}
#endif
#endif
#ifndef PERL_PV_ESCAPE_QUOTE
Acme-Testing-Permissions
view release on metacpan or search on metacpan
t/00-report-prereqs.t view on Meta::CPAN
}
if ( @reports ) {
push @full_reports, "=== $title ===\n\n";
my $ml = _max( map { length $_->[0] } @reports );
my $wl = _max( map { length $_->[1] } @reports );
my $hl = _max( map { length $_->[2] } @reports );
if ($type eq 'modules') {
splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl];
push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports;
}
Acme-Testing
view release on metacpan or search on metacpan
inc/Module/AutoInstall.pm view on Meta::CPAN
my $cwd = Cwd::cwd();
$Config = [];
my $maxlen = length(
(
sort { length($b) <=> length($a) }
grep { /^[^\-]/ }
map {
ref($_)
? ( ( ref($_) eq 'HASH' ) ? keys(%$_) : @{$_} )
: ''
Acme-Tests
view release on metacpan or search on metacpan
inc/Module/Install/Makefile.pm view on Meta::CPAN
sub clean_files {
my $self = shift;
my $clean = $self->makemaker_args->{clean} ||= {};
%$clean = (
%$clean,
FILES => join(' ', grep length, $clean->{FILES}, @_),
);
}
sub realclean_files {
my $self = shift;
my $realclean = $self->makemaker_args->{realclean} ||= {};
%$realclean = (
%$realclean,
FILES => join(' ', grep length, $realclean->{FILES}, @_),
);
}
sub libs {
my $self = shift;
Acme-Text-Shorten-ForTwitter
view release on metacpan or search on metacpan
lib/Acme/Text/Shorten/ForTwitter/Plugin/Contractions.pm view on Meta::CPAN
"you will" => "you'll",
"you are" => "you're",
"you have" => "you've",
);
for my $c (reverse sort { length $a <=> length $b } keys %contractions) {
$$text =~ s/(\b)$c(\b)/$contractions{$c}/g;
}
};
return;
Acme-Text-Viceversa
view release on metacpan or search on metacpan
lib/Acme/Text/Viceversa.pm view on Meta::CPAN
unless $str =~ /^(:?[ -~$list]+)$/o;
my @results = ();
my $string = '';
my $buffer = '';
while ( $string = substr( $str, 0, 1, '' ) or $string eq '0' ){
# some charactors have length 2 even if they were under utf8
if( exists $rot180{$string} ) {
unshift @results, $rot180{$string};
$buffer = '';
}else{
$buffer .= $string;
Acme-TextLayout
view release on metacpan or search on metacpan
lib/Acme/TextLayout.pm view on Meta::CPAN
./_whats_in_there($text);
./_widest($text);
$.textRef = $text;
map {
return undef unless length($_) == $.widest;
} @{$.textRef};
my %Ranges;
my %chars = %.chars;
map {
lib/Acme/TextLayout.pm view on Meta::CPAN
}
sub _widest {
my ($self, $textRef) = @_;
my @text = @$textRef;
my $widest = length($text[0]);
map {
my $len = length($_);
$widest = $len if $len > $widest;
} @text;
$.widest = $widest;
}
Acme-Throw
view release on metacpan or search on metacpan
t/lib/Capture/Tiny.pm view on Meta::CPAN
my %got;
if ( defined wantarray or ($do_tee && keys %localize) ) {
for ( keys %do ) {
_relayer($stash->{capture}{$_}, $layers{$_});
$got{$_} = _slurp($_, $stash);
# _debug("# slurped " . length($got{$_}) . " bytes from $_\n");
}
print CT_ORIG_STDOUT $got{stdout}
if $do_stdout && $do_tee && $localize{stdout};
print CT_ORIG_STDERR $got{stderr}
if $do_stderr && $do_tee && $localize{stderr};
Acme-Time-Constant
view release on metacpan or search on metacpan
t/00-report-prereqs.t view on Meta::CPAN
}
if ( @reports ) {
push @full_reports, "=== $title ===\n\n";
my $ml = _max( map { length $_->[0] } @reports );
my $wl = _max( map { length $_->[1] } @reports );
my $hl = _max( map { length $_->[2] } @reports );
if ($type eq 'modules') {
splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl];
push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports;
}
Acme-Tools
view release on metacpan or search on metacpan
print percentile(25, 101..199); # 125
my @list = minus(\@listA, \@listB); # set operation
my @list = union(\@listA, \@listB); # set operation
print length(gzip("abc" x 1000)); # far less than 3000
writefile("/dir/filename",$string); # convenient
my $s=readfile("/dir/filename"); # also convenient
print "yes!" if between($PI,3,4);
Example:
print num2code(255,2,"0123456789ABCDEF"); # prints FF
print num2code( 14,2,"0123456789ABCDEF"); # prints 0E
...because 255 are converted to hex FF (base C<< length("0123456789ABCDEF") >> ) which is 2 digits of 0-9 or A-F.
...and 14 are converted to 0E, with leading 0 because of the second argument 2.
Example:
print num2code(1234,16,"01")
#Math::BaseCnv
sub num2code {
return num2code($_[0],0,$_[1]) if @_==2;
my($num,$digits,$validchars,$start)=@_;
my $l=length($validchars);
my $key;
$digits||=9e9;
no warnings;
croak if $num<$start;
$num-=$start;
return $key;
}
sub code2num {
my($code,$validchars,$start)=@_; $start=0 if!defined$start;
my $l=length($validchars);
my $num=0;
$num=$num*$l+index($validchars,$_) for split//,$code;
return $num+$start;
}
kcal, kilocalorie, kilocalories,
newtonmeter, newtonmeters, th, thermie
force: N, _N, dyn, dyne, dynes, lb, newton
length: NM, _m, _pc, astronomical unit, au, chain, ft, furlong,
in, inch, inches, km, league, lightyear, ls, ly,
m, meter, meters, mi, mil, mile, miles,
nautical mile, nautical miles, nmi,
parsec, pc, planck, yard, yard_imperical, yd, Å, ångstrøm, angstrom
#TODO: @arr2=conv(\@arr1,"from","to") # should be way faster than:
#TODO: @arr2=map conv($_,"from","to"),@arr1
#TODO: conv(123456789,'b','h'); # h converts to something human-readable
our %conv=(
length=>{
m => 1,
_m => 1,
meter => 1,
meters => 1,
metre => 1,
pc => 149597870700*648000/$PI, #3.0857e16 = 3.26156 ly
_pc => 149597870700*648000/$PI,
parsec => 149597870700*648000/$PI,
attoparsec => 149597870700*648000/$PI/1e18,
apc => 149597870700*648000/$PI/1e18,
planck => 1.61619997e-35, #planck length
#Norwegian (old) lengths:
tomme => 0.0254,
tommer => 0.0254,
fot => 0.0254*12, #0.3048m
alen => 0.0254*12*2, #0.6096m
favn => 0.0254*12*2*3, #1.8288m
kvart => 0.0254*12*2/4, #0.1524m a quarter alen
#--https://upload.wikimedia.org/wikipedia/commons/e/eb/English_length_units_graph.svg
twip => 0.0254 / 6 / 12 / 20,
point => 0.0254 / 6 / 12,
pica => 0.0254 / 6,
line => 0.0254 / 12,
thou => 0.0254 / 1000,
millennium => 1000 * 60*60*24*365.2425,
shake => 1e-8,
moment => 3600/40, #1/40th of an hour, used by Medieval Western European computists
ke => 864, #1/100th of a day, trad Chinese, 14m24s
fortnight => 14*24*3600,
tp => 5.3910632e-44, #planck time, time for ligth to travel 1 planck length
nanocentury => 100 * 60*60*24*365.2425 / 1e9, #3.156 ~ pi seconds, response time limit (usability)
warhol => 15*60, #"fifteen minutes of fame"
},
speed=>{
'm/s' => 1,
sub sec_readable {
my $s=shift();
my($h,$d,$y)=(3600,24*3600,365.25*24*3600);
!defined$s ? undef
:!length($s) ? ''
:$s<0 ? '-'.sec_readable(-$s)
:$s<60 && int($s)==$s
? $s."s"
:$s<60 ? sprintf("%.*fs",int(3+-log($s)/log(10)),$s)
:$s<3600 ? int($s/60)."m " .($s%60) ."s"
#alternative algorithm: http://www.rapidtables.com/convert/number/how-number-to-roman-numerals.htm
#see also t/17_roman.t sub int2roman_old
sub int2roman {
my $n=shift;
!defined$n ? undef
: !length($n) ? ""
: $n<0 ? "-".int2roman(-$n)
: int($n)!=$n ? croak"int2roman: $n is not an integer"
# : $] >= 5.014 ? #s///r modifier introduced in perl v5.14
# ("I" x $n)
# =~s,I{1000},M,gr #unnecessary, but speedup for n>1000
# : $r=~s,^X,,i ? 10+roman2int($r)
# : $r=~s,^IX,,i ? 9+roman2int($r)
# : $r=~s,^V,,i ? 5+roman2int($r)
# : $r=~s,^IV,,i ? 4+roman2int($r)
# : $r=~s,^I,,i ? 1+roman2int($r)
# : !length($r) ? 0
# : croak "Invalid roman number $r";
#}
=head2 distance
sub fractional { #http://mathcentral.uregina.ca/QQ/database/QQ.09.06/h/lil1.html
carp "fractional: NOT FINISHED";
my $n=shift;
print "----fractional n=$n\n";
my $nn=$n; my $dec;
$nn=~s,\.(\d+)$,$dec=length($1);$1.,;
my $l;
my $max=0;
my($te,$ne);
for(1..length($nn)/2){
if( $nn=~/^(\d*?)((.{$_})(\3)+)$/ ){
print "_ = $_ ".length($2)."\n";
if(length($2)>$max){
$l=$_;
$te="$1$3"-$1;
$max=length($2);
}
}
}
return fractional($n) if !$l and !recursed() and $dec>6 and substr($n,-1) and substr($n,-1)--;
print "l=$l max=$max\n";
=head2 lpad
=head2 rpad
Left or right pads a string to the given length by adding one or more spaces at the end for I<rpad> or at the start for I<lpad>.
B<Input:> First argument: string to be padded. Second argument: length of the output. Optional third argument: character(s) used to pad.
Default is space.
rpad('gomle',9); # 'gomle '
lpad('gomle',9); # ' gomle'
rpad('gomle',9,'-'); # 'gomle----'
rpad('gomle',7,'xyz'); # 'gomlxy'
lpad('gomle',10,'xyz'); # 'xyzxygoml'
=head2 cpad
Center pads. Pads the string both on left and right equal to the given length. Centers the string. Pads right side first.
cpad('mat',5) eq ' mat '
cpad('mat',4) eq 'mat '
cpad('mat',6) eq ' mat '
cpad('mat',9) eq ' mat '
$s;
}
sub rpad {
my($s,$l,$p)=@_;
$p=' ' if @_<3 or !length($p);
$s.=$p while length($s)<$l;
substr($s,0,$l);
}
sub lpad {
my($s,$l,$p)=@_;
$p=' ' if @_<3 or !length($p);
$l<length($s)
? substr($s,0,$l)
: substr($p x (1+$l/length($p)), 0, $l-length($s)).$s;
}
sub cpad {
my($s,$l,$p)=@_;
$p=' ' if @_<3 or !length($p);
my $ls=length($s);
return substr($s,0,$l) if $l<$ls;
$p=$p x (($l-$ls+2)/length($p));
substr($p, 0, ($l-$ls )/2) . $s .
substr($p, 0, ($l-$ls+1)/2);
}
sub cpad_old {
my($s,$l,$p)=@_;
$p=' ' if !length($p);
return substr($s,0,$l) if $l<length($s);
my $i=0;
while($l>length($s)){
my $pc=substr($p,($i==int($i)?1:-1)*($i%length($p)),1);
$i==int($i) ? ($s.=$pc) : ($s=$pc.$s);
$i+=1/2;
}
$s;
}
sub trigram { sliding($_[0],$_[1]||3) }
sub sliding {
my($s,$w)=@_;
return map substr($s,$_,$w), 0..length($s)-$w if !ref($s);
return map [@$s[$_..$_+$w-1]], 0..@$s-$w if ref($s) eq 'ARRAY';
}
sub chunks {
my($s,$w)=@_;
=head1 ARRAYS
=head2 subarr
The equivalent of C<substr> on arrays or C<splice> without changing the array.
Input: 1) array or arrayref, 2) offset and optionally 3) length. Without a
third argument, subarr returns the rest of the array.
@top10 = subarr( @array, 0, 10); # first 10
@last_two = subarr( @array, -2, 2); # last 2
@last_two = subarr( $array_ref, -2); # also last 2
@last_six = subarr $array_ref, -6; # parens are optional
The same can be obtained from C<< @array[$from..$to] >> but that dont work the
same way with negative offsets and boundary control of length.
=cut
#Todo: sjekk paastand over
=head2 min
Returns the smallest number in a list. Undef is ignored.
@lengths=(2,3,5,2,10,undef,5,4);
$shortest = min(@lengths); # returns 2
Note: The comparison operator is perls C<< < >>> which means empty strings is treated as C<0>, the number zero. The same goes for C<max()>, except of course C<< > >> is used instead.
min(3,4,5) # 3
min(3,4,5,undef) # 3
=cut
sub sim_perm {
require String::Similarity;
my($s1,$s2)=map {s/^\s*(.+?)\s*$/$1/;$_} map upper($_), @_; #/r v5.14
croak if !length($s1) or !length($s2);
my $max;
for(cart([permutations(split(/[\s,]+/,$s1))],
[permutations(split(/[\s,]+/,$s2))])) {
my($n1,$n2)=@$_;
if(@$n1>@$n2){ pop@$n1 while @$n1>@$n2 }
Extended grep.
Works like L<grep> but with more insight: local vars $i, $n, $prev, $next, $prevr and $nextr are available:
$i is the current index, starts with 0, ends with the length of the input array minus one
$n is the current element number, starts with 1, $n = $i + 1
$prev is the previous value (undef if current is first)
=head2 parta
Like L<parth> but returns an array of lists where the predicate returns an index number.
my @a = parta { length } qw/These are the words of this array/;
Result:
@a = ( undef, undef, ['of'], ['are','the'], ['this'], ['These','words','array'] )
Two undefs at first (index positions 0 and 1) since there are no words of length 0 or 1 in the input array.
=cut
sub part (&@) { my($c,@r)=(shift,[],[]); push @{ $r[ &$c?0:1 ] }, $_ for @_; @r }
sub parth (&@) { my($c,%r)=(shift); push @{ $r{ &$c } }, $_ for @_; %r }
=head2 pile
B<Input:> a pile size s and a list
B<Output:> A list of lists of length s or the length of the remainer in
the last list. Piles together the input list in lists of the given size.
my @list=(1,2,3,4,5,6,7,8,9,10);
my @piles = pile(3, @list ); # ([1,2,3], [4,5,6], [7,8,9], [10])
my $i=0;
my($l,$s,$p,$nn,%ant,$t)=(0,0,0,0);
for my $r (@$aoh){
my $v=$$r{$c};
next if !defined$v or $v!~/\S/;
$nn++;
$l=length($v) if length($v)>$l;
no warnings 'uninitialized';
if($v=~/^(18|19|20)\d\d(0[1-9]|1[0-2])(0[1-9]|1\d|2\d|3[01])-?\d\d:?\d\d:?\d\d$/ and $conf{date}){
$ant{date}++;
next;
}
elsif($v=~/^\s*[-+]?(\d*)(\.\d+)?([Ee]\-?\d+)?\s*$/ and length("$1$2") and $conf{number}){
$ant{number}++;
$s=length("$1.$2") if length("$1.$2")>$s;#hm
$p=length($2)-1 if $2 and length($2)-1>$p;
next;
}
else {
$ant{varchar}++;
}
$tdb{$c}=$tdb;
}
my $sql;
$sql="create table $conf{name} (".
join(",",map sprintf("\n %-30s %s",do{s/\W+//g;$_},$tdb{$_}), @col). "\n);\n\n" if $conf{create};
my $val=sub{my($v,$t)=@_;defined$v or $v="";!length($v)?'null':$t eq 'number' ? $v : "'".repl($v,"\'","''")."'"};
for my $r (@$aoh){
my $v=join",",map &$val($$r{$_},$t{$_}), @col;
$sql.="insert into $conf{name} values ($v);\n";
}
$sql="drop table $conf{name};\n\n$sql" if $conf{drop}==1;
Generates random passwords.
B<Input:> 0-n args
* First arg: length of password(s), default 8
* Second arg: number of passwords, default 1
* Third arg: string containing legal chars in password, default A-Za-z0-9,-./&%_!
pwgen tries to find a password. Defaults for those are 0.01 and 10000.
Whenever one of the two limits is reached, a first generates a croak.
Examples:
my $pw=pwgen(); # a random 8 chars password A-Z a-z 0-9 ,-./&%!_ (8 is default length)
my $pw=pwgen(12); # a random 12 chars password A-Z a-z 0-9 ,-./&%!_
my @pw=pwgen(0,10); # 10 random 8 chars passwords, containing the same possible chars
my @pw=pwgen(0,1000,'A-Z'); # 1000 random 8 chars passwords containing just uppercase letters from A to Z
pwgen(3); # dies, defaults require chars in each of 4 group (see above)
$len||=8;
$num||=1;
$chars||='A-Za-z0-9,-./&%_!';
$req[0]||=\&pwgendefreq if !$_[2];
$chars=~s/([$_])-([$_])/join("","$1".."$2")/eg for ('a-z','A-Z','0-9');
my($c,$t,@pw,$d)=(length($chars),time_fp());
($Pwgen_trials,$Pwgen_sec)=(0,0);
TRIAL:
while(@pw<$num){
croak "pwgen timeout after $Pwgen_trials trials"
if ++$Pwgen_trials >= $Pwgen_max_trials
database or network transfer. Trades time for space. (Beware of wormholes)
=head2 zipb64
Compresses the input (text or binary) and returns a base64-encoded string of the compressed binary data.
No known limit on input length, several MB has been tested, as long as you've got the RAM...
B<Input:> One or two strings.
First argument: The string to be compressed.
same without base 64 encoding.
Example 1, normal compression without dictionary:
$txt = "Test av komprimering, hva skjer? " x 10; # ten copies of this norwegian string, $txt is now 330 bytes (or chars rather...)
print length($txt)," bytes input!\n"; # prints 330
$zip = zipb64($txt); # compresses
print length($zip)," bytes output!\n"; # prints 65
print $zip; # prints the base64 string ("noise")
$output=unzipb64($zip); # decompresses
print "Hurra\n" if $output eq $txt; # prints Hurra if everything went well
print length($output),"\n"; # prints 330
Example 2, same compression, now with dictionary:
$txt = "Test av komprimering, hva skjer? " x 10; # Same original string as above
$dict = "Testing av kompresjon, hva vil skje?"; # dictionary with certain similarities
# of the text to be compressed
$zip2 = zipb64($txt,$dict); # compressing with $dict as dictionary
print length($zip2)," bytes output!\n"; # prints 49, which is less than 65 in ex. 1 above
$output=unzipb64($zip2,$dict); # uses $dict in the decompressions too
print "Hurra\n" if $output eq $txt; # prints Hurra if everything went well
Example 3, dictionary = string to be compressed: (out of curiosity)
$txt = "Test av komprimering, hva skjer? " x 10; # Same original string as above
$zip3 = zipb64($txt,$txt); # hmm
print length($zip3)," bytes output!\n"; # prints 25
print "Hurra\n" if unzipb64($zip3,$txt) eq $txt; # hipp hipp ...
zipb64() and zipbin() is really just wrappers around L<Compress::Zlib> and C<inflate()> & co there.
=cut
=cut
our %IPNUM_memo;
sub ipnum {
my $ipaddr=shift;
#croak "No $ipaddr" if !length($ipaddr);
return $IPNUM_memo{$ipaddr} if exists $IPNUM_memo{$ipaddr};
my $h=gethostbyname($ipaddr);
#croak "No ipnum for $ipaddr" if !$h;
return if !defined $h;
my $ipnum = join(".",unpack("C4",$h));
read(STDIN,$query , $ENV{CONTENT_LENGTH});
$ENV{QUERY_STRING}=$query;
}
my %R;
for(split("&",$query)){
next if !length($_);
my($nkl,$verdi)=map urldec($_),split("=",$_,2);
$R{$nkl}=exists$R{$nkl}?"$R{$nkl},$verdi":$verdi;
}
return %R;
}
print username(); #just (getpwuid($<))[0] but more readable perhaps
=cut
sub basename { my($f,$s)=(@_,'');$s=quotemeta($s)if!ref($s);$f=~m,^(.*/)?([^/]*?)($s)?$,;$2 }
sub dirname { $_[0]=~m,^(.*)/,;defined($1) && length($1) ? $1 : '.' }
sub username { (getpwuid($<))[0] }
=head2 wipe
Deletes a file by "wiping" it on the disk. Overwrites the file before deleting. (May not work properly on SSDs)
$$hr{$1}||={};
}
elsif( $l=~/^\s*([^\:\=]+?)\s*[:=]\s*(.*?)\s*$/ ) {
my $ml=sub{my$v=shift;$v.="\n".shift@l while $v=~/^\{[^\}]*$/&&@l;$v=~s/^\{(.*)\}\s*$/$1/s;$v=~s,\\#,#,g;$v};
my $v=&$ml($2);
$$hr{$section}{$1}=$v if length($section) or $Read_conf_empty_section;
$$hr{$1}=$v if !length($section);
}
}
%$hr;
}
# my $incfn=sub{return $1 if $_[0]=~m,^(/.+),;my$f=$fn;$f=~s,[^/]+$,$_[0],;$f};
return if $_tms_inited++;
for(qw(MAANED Maaned maaned MAAN Maan maan),'MAANE.','Maane.','maane.'){
$Tms_str{$_}=$Tms_str{replace($_,"aa","Ã¥","AA","Ã…")};
}
$Tms_pattern=join("|",map{quotemeta($_)}
sort{length($b)<=>length($a)}
keys %Tms_str);
#without sort "måned" could be "mared" because "mån"=>"mar"
}
sub totime {
#http://rosettacode.org/wiki/Levenshtein_distance#Perl
our %ldist_cache;
sub ldist {
my($s,$t,$l) = @_;
return length($t) if !$s;
return length($s) if !$t;
%ldist_cache=() if !$l and 1000<0+%ldist_cache;
$ldist_cache{$s,$t} ||=
do {
my($s1,$t1) = ( substr($s,1), substr($t,1) );
substr($s,0,1) eq substr($t,0,1)
The I<no value> function (or I<null value> function)
C<nvl()> takes two or more arguments. (Oracles nvl-function take just two)
Returns the value of the first input argument with length() > 0.
Return I<undef> if there is no such input argument.
In perl 5.10 and perl 6 this will most often be easier with the C< //
> operator, although C<nvl()> and C<< // >> treats empty strings C<"">
differently. Sub nvl here considers empty strings and undef the same.
=cut
sub nvl {
return $_[0] if defined $_[0] and length($_[0]) or @_==1;
return $_[1] if @_==2;
return nvl(@_[1..$#_]) if @_>2;
return undef;
}
...although this has no meaning to C<Acme::Tools::ccn_ok()>.
The first six digits is I<Issuer Identifier>, that is the bank
(probably). The rest in the "account number", except the last digits,
which is the control digit. Max length on credit card numbers are 19
digits.
=cut
sub ccn_ok {
#print "Bakerst<$bakerst>\n";
for(@$tabref){
my $rad=join($;,@$_[0..($antned-1)]);
my $felt=join($;,@$_[$antned..($bakerst-1)]);
my $verdi=$$_[$bakerst];
length($rad) or $rad=' ';
length($felt) or $felt=' ';
$h{$rad}{$felt}=$verdi;
$h{$rad}{"%$felt"}=$verdi;
if($opt_sum or defined $opt_pro){
$h{$rad}{Sum}+=$verdi;
$sum{$felt}+=$verdi;
}
else{
my $height=0;
my $wider;
no warnings;
$not_empty[$j]=1 if !$head && length($cell)>0;
for(split("\n",$cell)){
$wider=/<input.+type=text.+size=(\d+)/i?$1:0; #hm
s/<[^>]+>//g;
$height++;
s/>/>/g;
s/</</g;
$width[$j]=length($_)+1+$wider if length($_)+1+$wider>$width[$j];
$left[$j]=1 if $_ && !/^\s*[\-\+]?(\d+|\d*\.\d+)\s*\%?$/ && !$head;
}
if( $height>1 && !$no_multiline_space){
$height++ if !$head;
$height[$i-1]++ if $i>1 && $height[$i-1]==1;
else{
for my $y (0..$j){
next if $remove_empty && !$not_empty[$y];
no warnings;
my @cell = !$header_last&&$nodup&&$nodup[$x][$y]
? ($nodup>0?():((" " x (($width[$y]-length($nodup))/2)).$nodup))
: split("\n",$$tab[$x][$y]);
for(0..($height[$x]-1)){
my $line=$row_start_line+$_;
my $txt=shift(@cell);
$txt='' if !defined$txt;
$txt=sprintf("%*s",$width[$y]-1,$txt) if length($txt)>0 && !$left[$y] && ($x>0 || $no_header_line);
$tabout[$line].=$txt;
if($y==$j){
$tabout[$line]=~s/\s+$//;
}
else{
my $wider;
$wider = $txt=~/<input.+type=text.+size=(\d+)/i?1+$1:0;
$txt=~s/<[^>]+>//g;
$txt=~s/>/>/g;
$txt=~s/</</g;
$tabout[$line].= ' ' x ($width[$y]-length($txt)-$wider);
}
}
}
}
$row_start_line+=$height[$x];
=cut
sub cnttbl {
my $hr=shift;
my $maxlen=max(3,map length($_),keys%$hr);
join"",ref((values%$hr)[0])
?do{ map {my$o=$_;join("",map rpad($$o[0],$maxlen)." $_\n",split("\n",$$o[1]))}
map [$_,cnttbl($$hr{$_})],
sort keys%$hr }
:do{ my $sum=sum(values%$hr);
my $fmt=repl("%-xs %yd %6.2f%%\n",x=>$maxlen,y=>length($sum));
map sprintf($fmt,@$_,100*$$_[1]/$sum),
(map[$_,$$hr{$_}],sort{$$hr{$a}<=>$$hr{$b} or $a cmp $b}keys%$hr),
(['SUM',$sum]) }
}
our $Edcursor;
sub ed {
my($s,$cs,$p,$buf)=@_; #string, commands, point (or cursor)
return $$s=ed($$s,$cs,$p,$buf) if ref($s);
my($sh,$cl,$m,$t,@m)=(0,0,0,undef);
while(length($cs)){
my $n = 0;
my $c = $cs=~s,^(M\d+|M.|""|".+?"|S.+?R|\\.|.),,s ? $1 : die;
$p = curb($p||0,0,length($s));
if(defined$t){$cs="".($c x $t).$cs;$t=undef;next}
my $add=sub{substr($s,$p,0)=$_[0];$p+=length($_[0])};
if ($c =~ /^([a-z0-9 ])/){ &$add($sh^$cl?uc($1):$1); $sh=0 }
elsif($c =~ /^"(.+)"$/) { &$add($1) }
elsif($c =~ /^\\(.)/) { &$add($1) }
elsif($c =~ /^S(.+)R/) { my $i=index($s,$1,$p);$p=$i+length($1) if $i>=0 }
elsif($c =~ /^M(\d+)/) { $t=$1; next }
elsif($c eq 'F') { $p++ }
elsif($c eq 'B') { $p-- }
elsif($c eq 'A') { $p-- while $p>0 and substr($s,$p-1,2)!~/^\n/ }
elsif($c eq 'E') { substr($s,$p)=~/(.*)/ and $p+=length($1) }
elsif($c eq 'D') { substr($s,$p,1)='' }
elsif($c eq 'MD'){ substr($s,$p)=~s/^(\W*\w+)// and $buf=$1 }
elsif($c eq 'MF'){ substr($s,$p)=~/(\W*\w+)/ and $p+=length($1) }
elsif($c eq 'MB'){ substr($s,0,$p)=~/(\w+\W*)$/ and $p-=length($1) }
elsif($c eq '-') { substr($s,--$p,1)='' if $p }
elsif($c eq 'M-'){ substr($s,0,$p)=~s/(\w+\W*)$// and $p-=length($buf=$1)}
elsif($c eq 'K') { substr($s,$p)=~s/(\S.+|\s*?\n)// and $buf=$1 }
elsif($c eq 'Y') { &$add($buf) }
elsif($c eq 'U') { substr($s,$p)=~s/(\W*)(\w+)/$1\U$2\E/; $p+=length($1.$2) }
elsif($c eq 'L') { substr($s,$p)=~s/(\W*)(\w+)/$1\L$2\E/; $p+=length($1.$2) }
elsif($c eq 'C') { substr($s,$p)=~s/(\W*)(\w+)/$1\u\L$2\E/; $p+=length($1.$2) }
elsif($c eq '<') { $p=0 }
elsif($c eq '>') { $p=length($s) }
elsif($c eq 'T') { $sh=1 }
elsif($c eq 'C') { $cl^=1 }
elsif($c eq '{') { $m=1; @m=() }
elsif($c eq '}') { $m=0 }
elsif($c eq '!') { $m||!@m and die"ed: no macro"; $cs=join("",@m).$cs }
data structures. Trading speed and accuracy for memory usage. While
risking false positives, Bloom filters have a very strong space
advantage over other data structures for representing sets.
In the example below, a set of 100000 phone numbers (or any string of
any length) can be "stored" in just 91230 bytes if you accept that you
can only check the data structure for existence of a string and accept
false positives with an error rate of 0.03 (that is three percent, error
rates are given in numbers larger than 0 and smaller than 1).
You can not retrieve the strings in the set without using "brute
Example: examine the frequency of the counters with 4 bit counters and 4 million keys:
my $bf=bfinit( error_rate=>0.001, capacity=>4e6, counting_bits=>4 );
bfadd($bf,[1e3*$_+1 .. 1e3*($_+1)]) for 0..4000-1; # adding 4 million keys one thousand at a time
my %c; $c{vec($$bf{filter},$_,$$bf{counting_bits})}++ for 0..$$bf{filterlength}-1;
printf "%8d counters = %d\n",$c{$_},$_ for sort{$a<=>$b}keys%c;
The output:
28689562 counters = 0
=head2 bfsum
Returns the number of 1's in the filter.
my $percent=100*bfsum($bf)/$$bf{filterlength};
printf "The filter is %.1f%% filled\n",$percent; #prints 50.0% or so if filled to capacity
Sums the counters for counting bloom filters (much slower than for non counting).
=head2 bfdimensions
overflow => {},
version => $Acme::Tools::VERSION,
};
croak "Error rate ($$bf{error_rate}) should be larger than 0 and smaller than 1" if $$bf{error_rate}<=0 or $$bf{error_rate}>=1;
@$bf{'min_hashfuncs','max_hashfuncs'}=(map$arg{hashfuncs},1..2) if $arg{hashfuncs};
@$bf{'filterlength','hashfuncs'}=bfdimensions($bf); #m and k
$$bf{filter}=pack("b*", '0' x ($$bf{filterlength}*$$bf{counting_bits}) ); #hm x new empty filter
$$bf{unpack}= $$bf{filterlength}<=2**16/4 ? "n*" # /4 alleviates skewing if m just slightly < 2**x
:$$bf{filterlength}<=2**32/4 ? "N*"
: "Q*";
bfadd($bf,@{$arg{keys}}) if $arg{keys};
return $bf;
}
sub bfaddbf {
my($bf,$bf2)=@_;
my $differror=join"\n",
map "Property $_ differs ($$bf{$_} vs $$bf2{$_})",
grep $$bf{$_} ne $$bf2{$_},
qw/capacity counting_bits adaptive hashfuncs filterlength/; #not error_rate
croak $differror if $differror;
croak "Can not add adaptive bloom filters" if $$bf{adaptive};
my $count=$$bf{key_count}+$$bf2{key_count};
croak "Exceeded filter capacity $$bf{key_count} + $$bf2{key_count} = $count > $$bf{capacity}"
if $count > $$bf{capacity};
$$bf{filter} |= $$bf2{filter};
#$$bf{filter} = $$bf{filter} | $$bf2{filter}; #or-ing
}
else {
my $cb=$$bf{counting_bits};
for(0..$$bf{filterlength}-1){
my $sum=
vec($$bf{filter}, $_,$cb)+
vec($$bf2{filter},$_,$cb);
if( $sum>2**$cb-1 ){
$sum=2**$cb-1;
}
sub bfsum {
my($bf)=@_;
return unpack( "%32b*", $$bf{filter}) if $$bf{counting_bits}==1;
my($sum,$cb)=(0,$$bf{counting_bits});
$sum+=vec($$bf{filter},$_,$cb) for 0..$$bf{filterlength}-1;
return $sum;
}
sub bfadd {
require Digest::MD5;
my($bf,@keys)=@_;
return if !@keys;
my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys;
my($m,$k,$up,$n,$cb,$adaptive)=@$bf{'filterlength','hashfuncs','unpack','capacity','counting_bits','adaptive'};
for(@$keysref){
#croak "Key should be scalar" if ref($_);
$$bf{key_count} >= $n and croak "Exceeded filter capacity $n" or $$bf{key_count}++;
my @h; push @h, unpack $up, Digest::MD5::md5($_,0+@h) while @h<$k;
if ($cb==1 and !$adaptive) { # normal bloom filter
}
}
}
elsif ($adaptive) { # adaptive bloom filter
my($i,$key,$bit)=(0+@h,$_);
for(0..$$bf{filterlength}-1){
$i+=push(@h, unpack $up, Digest::MD5::md5($key,$i)) if !@h;
my $pos=shift(@h) % $m;
$bit=vec($$bf{filter}, $pos, 1);
vec($$bf{filter}, $pos, 1)=1;
last if $_>=$k-1 and $bit==0;
sub bfcheck {
require Digest::MD5;
my($bf,@keys)=@_;
return if !@keys;
my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys;
my($m,$k,$up,$cb,$adaptive)=@$bf{'filterlength','hashfuncs','unpack','counting_bits','adaptive'};
my $wa=wantarray();
if(!$adaptive){ # normal bloom filter or counting bloom filter
return map {
my $match = 1; # match if every bit is on
my @h; push @h, unpack $up, Digest::MD5::md5($_,0+@h) while @h<$k;
} @$keysref;
}
else { # adaptive bloom filter
return map {
my($match,$i,$key,$bit,@h)=(1,0,$_);
for(0..$$bf{filterlength}-1){
$i+=push(@h, unpack $up, Digest::MD5::md5($key,$i)) if !@h;
my $pos=shift(@h) % $m;
$bit=vec($$bf{filter}, $pos, 1);
$match++ if $_ > $k-1 and $bit==1;
$match=0 if $_ <= $k-1 and $bit==0;
sub bfgrep { # just a copy of bfcheck with map replaced by grep
require Digest::MD5;
my($bf,@keys)=@_;
return if !@keys;
my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys;
my($m,$k,$up,$cb)=@$bf{'filterlength','hashfuncs','unpack','counting_bits'};
return grep {
my $match = 1; # match if every bit is on
my @h; push @h, unpack $up, Digest::MD5::md5($_,0+@h) while @h<$k;
vec($$bf{filter}, $h[$_] % $m, $cb) or $match=0 or last for 0..$k-1;
$match;
sub bfgrepnot { # just a copy of bfgrep with $match replaced by not $match
require Digest::MD5;
my($bf,@keys)=@_;
return if !@keys;
my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys;
my($m,$k,$up,$cb)=@$bf{'filterlength','hashfuncs','unpack','counting_bits'};
return grep {
my $match = 1; # match if every bit is on
my @h; push @h, unpack $up, Digest::MD5::md5($_,0+@h) while @h<$k;
vec($$bf{filter}, $h[$_] % $m, $cb) or $match=0 or last for 0..$k-1;
!$match;
sub bfdelete {
require Digest::MD5;
my($bf,@keys)=@_;
return if !@keys;
my $keysref=@keys==1 && ref($keys[0]) eq 'ARRAY' ? $keys[0] : \@keys;
my($m,$k,$up,$cb)=@$bf{'filterlength','hashfuncs','unpack','counting_bits'};
croak "Cannot delete from non-counting bloom filter (use counting_bits 4 e.g.)" if $cb==1;
for my $key (@$keysref){
my @h; push @h, unpack $up, Digest::MD5::md5($key,0+@h) while @h<$k;
$$bf{key_count}==0 and croak "Deleted all and then some" or $$bf{key_count}--;
my($ones,$croak,@pos)=(0);
sub base64 ($;$) { #
if ($] >= 5.006) {
require bytes;
croak "base64 failed: only defined for bytes"
if bytes::length($_[0]) > length($_[0])
or $] >= 5.008 && $_[0] =~ /[^\0-\xFF]/
}
my $eol=defined$_[1]?$_[1]:"\n";
my $res=pack("u",$_[0]);
$res=~s/^.//mg;
$res=~s/\n//g;
$res=~tr|` -_|AA-Za-z0-9+/|;
my $pad=(3-length($_[0])%3)%3;
$res=~s/.{$pad}$/'=' x $pad/e if $pad;
$res=~s/(.{1,76})/$1$eol/g if length($eol); #todo !=76
$res;
}
our $Fix_unbase64=0;
sub unbase64 ($) {
my $s=shift;
$s=~tr,0-9a-zA-Z+=/,,cd;
if($Fix_unbase64){ $s.='=' while length($s)%4 }
croak "unbase64 failed: length ".length($s)." not multiple of 4" if length($s)%4;
$s=~s/=+$//;
$s=~tr|A-Za-z0-9+/| -_|;
length($s) ? unpack("u",join'',map(chr(32+length($_)*3/4).$_,$s=~/(.{1,60})/gs)) : "";
}
=head1 COMMANDS
@r=map int($_), @r;
my $fmt=$o{t}?'YYYY/MM/DD-MM:MI:SS':'YYYY/MM/DD';
@r=map tms($_,$fmt), @r;
" ".join(" ",@r);
};
my $width=max( 10, grep $_, map length($_), @e );
@e=@e[-10..-1] if $o{t} and @e>10; #-t tail
printf("%-*s %8d $f %7.2f%%%s\n",$width,$_,$c{$_},&$s($b{$_}),100*$b{$_}/$bts,&$perc($_)) for @e;
printf("%-*s %8d $f %7.2f%%%s\n",$width,"Sum",$cnt,&$s($bts),100,&$perc());
}
sub cmd_resubst {
my $newfile=$o{o}?repl($file,qr/\.(gz|bz2|xz)$/i,".$oext"):$file;
rename("$file.tmp$$",$newfile) or croak"ERR: rename $file.tmp$$ -> $newfile failed\n";
if($o{v}){
my $pr=$bfr?100*$bto/$bfr:0;
printf "%*d/%d %*s %7d =>%8d b (%2d%%) %s\n",
length(0+@argv), ++$i, 0+@argv, -15, "$tc/$c", $bfr, $bto, $pr, $file;
$tbfr+=$bfr;
$tbto+=$bto;
}
}
if($o{v} and @argv>1){
if($a=~/^-([$o1])([$o].*)$/){
unshift@a,"-$1","-$2";
}
elsif($a=~/^-(\w)(.*)$/){
my $d=$def{$1}//0;
push@{$$hashref{$1}},$d==1 && length($2) ? croak"opt -$1 has no arg (is $2 here)"
:$d==1 ? 1
:$d==2 && length($2) ? $2
:$d==2 ? shift(@a)
:croak"unknown opt -$1";
}
elsif($a eq '--'){
last;
Acme-Turing
view release on metacpan or search on metacpan
Creates the Turing machine. The argument
is optional. It specifies a maximum number of steps that
the machine is allowed to go through before it is forced to stop
(to avoid endless looping); the default is 250 steps. The machine
will be created with a tape that is initially 200 squares in length.
Turing machine
tapes, however, are infinite, so the tape will be automatically made
longer whenever necessary; the only limit on the tape length is the
amount of available storage.
The newly created machine is in the START state. The tape is
initialized to a series of single blanks (i.e., scalars
of length 1 containing ' '). The tape head is positioned over the
middle of the tape, i.e. at C<int($tape_length/2)> = 100 =
the 101st symbol. Every square must contain
at least one character; empty strings are not allowed.
Also, blanks may not be written except by "erasing" (see below).
new() returns a hash reference. The specification for the machine
Acme-Types-NonStandard
view release on metacpan or search on metacpan
t/00-report-prereqs.t view on Meta::CPAN
}
if ( @reports ) {
push @full_reports, "=== $title ===\n\n";
my $ml = _max( map { length $_->[0] } @reports );
my $wl = _max( map { length $_->[1] } @reports );
my $hl = _max( map { length $_->[2] } @reports );
if ($type eq 'modules') {
splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl];
push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports;
}
Acme-Ukrop
view release on metacpan or search on metacpan
'ÎÅÈÁÊ' => 'my',
'ËÁÖÉ' => 'print',
'ÄiÊÓÔ×Ï' => 'sub',
'ÄÏËÉ' => 'while',
'ÑËÝÏ' => 'if',
'ÄÏ×ÖÉÎÁ' => 'length',
'ÇÅÔØ' => 'break',
'×iÄÒiÖÅÍÏÞÉ›ÝÏ'=> 'chomp',
);
my $k = join('|', sort keys %n);
Acme-Unicodify
view release on metacpan or search on metacpan
t/00-report-prereqs.t view on Meta::CPAN
}
if ( @reports ) {
push @full_reports, "=== $title ===\n\n";
my $ml = _max( map { length $_->[0] } @reports );
my $wl = _max( map { length $_->[1] } @reports );
my $hl = _max( map { length $_->[2] } @reports );
if ($type eq 'modules') {
splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl];
push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports;
}
Acme-VarMess
view release on metacpan or search on metacpan
inc/Module/Install/Makefile.pm view on Meta::CPAN
sub clean_files {
my $self = shift;
my $clean = $self->makemaker_args->{clean} ||= {};
%$clean = (
%$clean,
FILES => join(" ", grep length, $clean->{FILES}, @_),
);
}
sub libs {
my $self = shift;
Acme-Version-Hex
view release on metacpan or search on metacpan
inc/MyVersionProvider.pm view on Meta::CPAN
$content = $self->$orig($content, $params);
my $orig_version = ${ $params->{version} };
my $new_version = sprintf('%a', $orig_version);
$new_version .= ' ' x (List::Util::min(length($orig_version), 8) - length($new_version));
$content =~ s/^Revision history for Acme-Version-Hex\n\n\K$orig_version(\s+)/$new_version$1/;
return $content;
};
}
Acme-W
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
$s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
}
$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;
}
Acme-Wabby
view release on metacpan or search on metacpan
$word =~ s/'+$//g;
# Only allow the single-character words of 'a' and 'I'.
# FIXME - Need to be able to configure this so that persons with
# non-english texts can pick values that make sense.
if (length($word) == 1 && lc($word) ne "i" && lc($word) ne "a") {
$word = "";
$idx++;
next;
}
=over 8
=item min_len
The minimum length for a generated sentence. (3)
=item max_len
The maximum length for a generated sentence. (30)
=item punctuation
A reference to an array containing possible punctuation with which to end sentences. ([".","?","!","..."])
Acme-Win32-PEPM
view release on metacpan or search on metacpan
lib/Win32/PEPM/Build.pm view on Meta::CPAN
$text .= $nl.'__END__'.$nl if $pos == -1;
$text = 'MZ' #DOS MAGIC
.';' #make the magic not be a syntax error
.$nl.'#!!!!WARNING do not edit this file!!!!'.$nl
.' ' #space pad to the heredoc
x (0x40 #DOS headers full length
-length('MZ')
-length(';')
-length($nl.'#!!!!WARNING do not edit this file!!!!'.$nl)
-length('<<e_lfanew;'.$nl) #heredoc to escape
-4 #size of DWORD e_lfanew
)
.'<<e_lfanew;'.$nl #heredoc
."\x01\x01\x01\x01" #e_lfanew member, a U32/DWORD offset, will be overwritten by linker
#end of 0x40 area, things below are now supposed executable space of the dos prog
.$nl.'e_lfanew'.$nl.$nl #end quoting of the binary offset
.$text
#note the "Rich Signature" appears here before PE header
#after going through VC linker, the Rich Signature IS NOT uninitialized
#memory leaking from VC linker due to our garbage MZ header with invalid
#DOS executable lengths
;
write_file($file, {binmode => ':raw'}, $text);
}
sub WMHash {
lib/Win32/PEPM/Build.pm view on Meta::CPAN
$dlib = $self->SUPER::pm_to_blib(@_);
package main;
}
my $pos = index($dlib,'pm_to_blib : $(FIRST_MAKEFILE) $(TO_INST_PM)',0);
die 'bad pm_to_blib match' if $pos == -1;
$pos += length 'pm_to_blib : $(FIRST_MAKEFILE) $(TO_INST_PM)';
substr($dlib, $pos, 0, ' $(INST_DYNAMIC)'); #depend on the DLL built
$pos = index($dlib,' $(NOECHO) $(TOUCH) pm_to_blib',0);
die "bad pm_to_blib match" if $pos == -1;
#file is copied twice, but for simplicity don't remove the 1st copying cmd
lib/Win32/PEPM/Build.pm view on Meta::CPAN
$dlib = $self->SUPER::constants(@_);
package main;
}
my $pos = index($dlib,'INST_DYNAMIC = $(INST_ARCHAUTODIR)\$(DLBASE).$(DLEXT)',0);
die 'bad constants match' if $pos == -1;
substr($dlib, $pos, length('INST_DYNAMIC = $(INST_ARCHAUTODIR)\$(DLBASE).$(DLEXT)'),
'INST_DYNAMIC = $(DLBASE).$(DLEXT)');
return $dlib;
};
}
}
Acme-YAPC-Asia-2012-LTthon-Hakushu
view release on metacpan or search on metacpan
inc/Module/Install.pm view on Meta::CPAN
$s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg;
}
$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;
}
Acme-YAPC-Okinawa-Bus
view release on metacpan or search on metacpan
lib/Acme/YAPC/Okinawa/ppport.h view on Meta::CPAN
mg_findext|5.013008||pn
mg_find|||n
mg_free_type||5.013006|
mg_free|||
mg_get|||
mg_length||5.005000|
mg_localize|||
mg_magical|||n
mg_set|||
mg_size||5.005000|
mini_mktime||5.007002|n
lib/Acme/YAPC/Okinawa/ppport.h view on Meta::CPAN
reg_named_buff_nextkey||5.009005|
reg_named_buff_scalar||5.009005|
reg_named_buff|||
reg_node|||
reg_numbered_buff_fetch|||
reg_numbered_buff_length|||
reg_numbered_buff_store|||
reg_qr_package|||
reg_recode|||
reg_scan_name|||
reg_skipcomment|||n
lib/Acme/YAPC/Okinawa/ppport.h view on Meta::CPAN
utf16_textfilter|||
utf16_to_utf8_reversed||5.006001|
utf16_to_utf8||5.006001|
utf8_distance||5.006000|
utf8_hop||5.006000|n
utf8_length||5.007001|
utf8_mg_len_cache_update|||
utf8_mg_pos_cache_update|||
utf8_to_bytes||5.006001|
utf8_to_uvchr_buf||5.015009|
utf8_to_uvchr||5.007001|
lib/Acme/YAPC/Okinawa/ppport.h view on Meta::CPAN
if (exists $opt{'list-unsupported'}) {
my $f;
for $f (sort { lc $a cmp lc $b } keys %API) {
next unless $API{$f}{todo};
print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n";
}
exit 0;
}
# Scan for possible replacement candidates
lib/Acme/YAPC/Okinawa/ppport.h view on Meta::CPAN
#ifndef ERRSV
# define ERRSV get_sv("@",FALSE)
#endif
/* Hint: gv_stashpvn
* This function's backport doesn't support the length parameter, but
* rather ignores it. Portability can only be ensured if the length
* parameter is used for speed reasons, but the length can always be
* correctly computed from the string argument.
*/
#ifndef gv_stashpvn
# define gv_stashpvn(str,len,create) gv_stashpv(str,create)
#endif
lib/Acme/YAPC/Okinawa/ppport.h view on Meta::CPAN
#if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL)
Size_t
DPPP_(my_my_strlcat)(char *dst, const char *src, Size_t size)
{
Size_t used, length, copy;
used = strlen(dst);
length = strlen(src);
if (size > 0 && used < size - 1) {
copy = (length >= size - used) ? size - used - 1 : length;
memcpy(dst + used, src, copy);
dst[used + copy] = '\0';
}
return used + length;
}
#endif
#endif
#if !defined(my_strlcpy)
lib/Acme/YAPC/Okinawa/ppport.h view on Meta::CPAN
#if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL)
Size_t
DPPP_(my_my_strlcpy)(char *dst, const char *src, Size_t size)
{
Size_t length, copy;
length = strlen(src);
if (size > 0) {
copy = (length >= size) ? size - 1 : length;
memcpy(dst, src, copy);
dst[copy] = '\0';
}
return length;
}
#endif
#endif
#ifndef PERL_PV_ESCAPE_QUOTE
Acme-Yoda
view release on metacpan or search on metacpan
lib/Acme/Yoda.pm view on Meta::CPAN
# Find out if I have a pivot word and grab the one with the lowest index
my $pivot = $self->_get_pivot();
return $sentence if (!$pivot);
if (index(lc($sentence),$pivot) == 0) {
$sentence = substr($sentence,,length($pivot)+1);
$ending = '?';
} else {
return $sentence unless ($sentence=~/\b$pivot\b/);
$sentence="$' $`$&";
}
Acme-Zalgo
view release on metacpan or search on metacpan
lib/Acme/Zalgo.pm view on Meta::CPAN
return int(rand($max - $min)) + $min;
}
sub rand_char {
my ($s) = @_;
return substr($s, randint(length $s), 1);
}
sub zalgo_char {
my ($c, $upmin, $upmax, $midmin, $midmax, $downmin, $downmax) = @_;
for my $i (1..randint($upmin, $upmax)) {
Acme-constant
view release on metacpan or search on metacpan
push @{(STRUCTURE)}, 'hello';
is_deeply STRUCTURE, [4, {2 => 7}, 'hello'], 'Can push to arrays';
$#{(STRUCTURE)} = 0;
is_deeply STRUCTURE, [4], 'Can change length of array reference in structure';
Acme-emcA
view release on metacpan or search on metacpan
inc/Module/Install/Makefile.pm view on Meta::CPAN
sub clean_files {
my $self = shift;
my $clean = $self->makemaker_args->{clean} ||= {};
%$clean = (
%$clean,
FILES => join(' ', grep length, $clean->{FILES}, @_),
);
}
sub realclean_files {
my $self = shift;
my $realclean = $self->makemaker_args->{realclean} ||= {};
%$realclean = (
%$realclean,
FILES => join(' ', grep length, $realclean->{FILES}, @_),
);
}
sub libs {
my $self = shift;
Acme-require-case
view release on metacpan or search on metacpan
t/00-report-prereqs.t view on Meta::CPAN
}
if ( @reports ) {
push @full_reports, "=== $title ===\n\n";
my $ml = _max( map { length $_->[0] } @reports );
my $wl = _max( map { length $_->[1] } @reports );
my $hl = _max( map { length $_->[2] } @reports );
if ($type eq 'modules') {
splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl];
push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports;
}
Acme-use-strict-with-pride
view release on metacpan or search on metacpan
# caller-filter leaves some data in the buffer, and filter gets to see
# it in $_ for a second time.
if (@lines) {
push @lines, $_;
$_ = shift @lines;
return length $_;
}
return 0;
});
}
}
Acrux-DBI
view release on metacpan or search on metacpan
lib/Acrux/DBI.pm view on Meta::CPAN
my $dsn = '';
my $db = $self->database;
if ($dr eq 'sqlite' or $dr eq 'file') {
$dsn = sprintf('DBI:SQLite:dbname=%s', $db);
} elsif ($dr eq 'mysql') {
push @params, sprintf("%s=%s", "database", $db) if length $db;
push @params, sprintf("%s=%s", "host", $self->host);
push @params, sprintf("%s=%s", "port", $self->port) if $self->port;
$dsn = sprintf('DBI:mysql:%s', join(";", @params) || '');
} elsif ($dr eq 'maria' or $dr eq 'mariadb') {
push @params, sprintf("%s=%s", "database", $db) if length $db;
push @params, sprintf("%s=%s", "host", $self->host);
push @params, sprintf("%s=%s", "port", $self->port) if $self->port;
$dsn = sprintf('DBI:MariaDB:%s', join(";", @params) || '');
} elsif ($dr eq 'pg' or $dr eq 'pgsql' or $dr eq 'postgres' or $dr eq 'postgresql') {
push @params, sprintf("%s=%s", "dbname", $db) if length $db;
push @params, sprintf("%s=%s", "host", $self->host);
push @params, sprintf("%s=%s", "port", $self->port) if $self->port;
$dsn = sprintf('DBI:Pg:%s', join(";", @params) || '');
} elsif ($dr eq 'oracle') {
push @params, sprintf("%s=%s", "host", $self->host);
push @params, sprintf("%s=%s", "sid", $db) if length $db;
push @params, sprintf("%s=%s", "port", $self->port) if $self->port;
$dsn = sprintf('DBI:Oracle:%s', join(";", @params) || '');
} else {
$dsn = DEFAULT_DBI_DSN;
}
lib/Acrux/DBI.pm view on Meta::CPAN
? {%{$_[0]}}
: {bind_values => [@_]}
: {};
$self->{error} = '';
return unless my $dbh = $self->dbh;
unless (length($sql)) {
$self->error("No statement specified");
return;
}
# Prepare
Acrux
view release on metacpan or search on metacpan
lib/Acme/Crux.pm view on Meta::CPAN
}
# Root dir
my $root = $self->{root};
$root = $self->{root} = $pwd if defined($root) && $root eq '.';
unless (defined($root) && length($root)) {
$root = $self->{root} = File::Spec->catdir(SYSCONFDIR, $moniker);
}
# Temp dir
my $temp = $self->{tempdir};
unless (defined($temp) && length($temp)) {
$temp = $self->{tempdir} = File::Spec->catdir(File::Spec->tmpdir(), $moniker);
}
# Data dir
my $datadir = $self->{datadir};
unless (defined($datadir) && length($datadir)) {
$datadir = $self->{datadir} = File::Spec->catdir(SHAREDSTATEDIR, $moniker);
}
# Log dir
my $logdir = $self->{logdir};
unless (defined($logdir) && length($logdir)) {
$logdir = $self->{logdir} = File::Spec->catdir(LOGDIR, $moniker);
}
# Share dir
my $sharedir = $self->{sharedir};
unless (defined($sharedir) && length($sharedir)) {
$self->{sharedir} = File::Spec->catdir(DATADIR, $moniker);
}
# Doc dir
my $docdir = $self->{docdir};
unless (defined($docdir) && length($docdir)) {
$self->{docdir} = File::Spec->catdir(DOCDIR, $moniker);
}
# Cache dir
my $cachedir = $self->{cachedir};
unless (defined($cachedir) && length($cachedir)) {
$self->{cachedir} = File::Spec->catdir(CACHEDIR, $moniker);
}
# Spool dir
my $spooldir = $self->{spooldir};
unless (defined($spooldir) && length($spooldir)) {
$self->{spooldir} = File::Spec->catdir(SPOOLDIR, $moniker);
}
# Run dir
my $rundir = $self->{rundir};
unless (defined($rundir) && length($rundir)) {
$rundir = $self->{rundir} = File::Spec->catdir(RUNDIR, $moniker);
}
# Lock dir
my $lockdir = $self->{lockdir};
unless (defined($lockdir) && length($lockdir)) {
$self->{lockdir} = File::Spec->catdir(LOCKDIR, $moniker);
}
# Web dir
my $webdir = $self->{webdir};
unless (defined($webdir) && length($webdir)) {
$self->{webdir} = File::Spec->catdir(WEBDIR, $moniker);
}
# Config file
my $configfile = $self->{configfile};
unless (defined($configfile) && length($configfile)) {
$self->{configfile} = File::Spec->catfile(IS_ROOT ? $root : $pwd, sprintf("%s.conf", $moniker));
}
# Log file
my $logfile = $self->{logfile};
unless (defined($logfile) && length($logfile)) {
$self->{logfile} = File::Spec->catfile(IS_ROOT ? $logdir : $pwd, sprintf("%s.log", $moniker));
}
# PID file
my $pidfile = $self->{pidfile};
unless (defined($pidfile) && length($pidfile)) {
$self->{pidfile} = File::Spec->catfile(IS_ROOT ? $rundir : $pwd, sprintf("%s.pid", $moniker));
}
# Define plugins list to plugin map
$self->plugins(as_hash_ref($args->{plugins}));
lib/Acme/Crux.pm view on Meta::CPAN
return $self->{plugins} if scalar(@_) < 1;
my $args = @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {};
my $plugins = $self->{plugins};
foreach my $k (keys %$args) {
next if exists($plugins->{$k}) && $plugins->{$k}->{loaded}; # Skip loaded plugins
$plugins->{$k} = { class => $args->{$k}, loaded => 0 } if length($args->{$k} // '');
}
return $self;
}
sub plugin {
my $self = shift;
my $name = shift // ''; # Plugin name
my $class = shift // ''; # Plugin class
my @args = @_;
my $plugins = $self->{plugins}; # Get list of plugins
return unless length $name;
# Lookup class by name
unless (length($class)) {
# Lookup in existing plugins
$class = $plugins->{$name}->{class} // '' if exists $plugins->{$name};
# Lookup in defaults
$class = DEFAULT_PLUGINS()->{$name} // '' unless length $class;
}
return unless length $class;
# Register found plugin
$self->register_plugin($name, $class, @args); # name, class, args
}
sub register_plugin {
my $self = shift;
my $name = shift // ''; # Plugin name
my $class = shift // ''; # Plugin class
my $args = @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {}; # Plugin arguments
my $plugins = $self->{plugins};
croak "No plugin name specified!" unless length $name;
croak "No plugin class specified!" unless length $class;
# Load plugin if not exists in already loaded plugins list
return 1 if exists($plugins->{$name}) && $plugins->{$name}->{loaded};
if (my $error = load_class($class)) {
$self->verbosemode
lib/Acme/Crux.pm view on Meta::CPAN
$Acme::Crux::Sandbox::HANDLERS{$k} = {} unless exists($Acme::Crux::Sandbox::HANDLERS{$k});
my $handlers = $Acme::Crux::Sandbox::HANDLERS{$k};
# Handler name
my $name = trim($info{handler} // $info{name} // 'default');
croak("The handler name missing") unless length($name);
delete $info{handler};
$info{name} = $name;
croak("The $name duplicate handler definition") if defined($handlers->{$name});
# Handler aliases
lib/Acme/Crux.pm view on Meta::CPAN
$_aliases = [ trim($_aliases) ] unless is_array_ref($_aliases);
my $aliases = words(@$_aliases);
#foreach my $al (@$_aliases) {
# next unless defined($al) && is_value($al);
# foreach my $p (split(/[\s;,]+/, $al)) {
# next unless defined($p) && length($p);
# $aliases{$p} = 1;
# }
#}
delete $info{alias};
$info{aliases} = [grep {$_ ne $name} @$aliases];
lib/Acme/Crux.pm view on Meta::CPAN
return 1;
}
sub lookup_handler {
my $self = shift;
my $name = trim(shift // '');
return undef unless length $name;
my $invocant = ref($self) || scalar(caller(0));
my $handlers = $Acme::Crux::Sandbox::HANDLERS{"$invocant.$$"};
return undef unless defined($handlers) && is_hash_ref($handlers);
foreach my $n (keys %$handlers) {
my $aliases = as_array_ref($handlers->{$n}->{aliases});
lib/Acme/Crux.pm view on Meta::CPAN
# All: names and aliases
my %seen = ();
foreach my $n (keys %$handlers) {
my $aliases = as_array_ref($handlers->{$n}->{aliases});
foreach my $_a ($n, @$aliases) {
$seen{$_a} = 1 if defined($_a) and length($_a);
}
}
return [(sort {$a cmp $b} keys %seen)];
}
sub run_handler {
lib/Acme/Crux.pm view on Meta::CPAN
my @args = @_;
if ($self->{running}) {
$self->error(sprintf(qq{The application "%s" is already runned}, $self->project));
return 0;
}
unless(length($name)) {
$self->error("Invalid handler name");
return 0;
}
my $meta = $self->lookup_handler($name);
unless ($meta) {
lib/Acme/Crux.pm view on Meta::CPAN
my $prj = shift;
return unless defined($prj);
$prj =~ s/::/-/g;
$prj =~ s/[^A-Za-z0-9_\-.]/_/g; # Remove incorrect chars
$prj =~ s/([_\-.]){2,}/$1/g; # Remove dubles
return unless length($prj);
return lc($prj);
}
1;
( run in 0.525 second using v1.01-cache-2.11-cpan-65fba6d93b7 )