view release on metacpan or search on metacpan
}
sub binary2ascii {
return str2ascii(binary2str(@_));
}
sub ascii2binary {
return str2binary(ascii2str($_[$[]));
}
sub str2binary { my @str = split //, $_[$[];
my @intarray = (); my $ii = $[;
while (1) {
last unless @str; $intarray[$ii] = (0xFF & ord shift @str)<<24;
last unless @str; $intarray[$ii] |= (0xFF & ord shift @str)<<16;
last unless @str; $intarray[$ii] |= (0xFF & ord shift @str)<<8;
last unless @str; $intarray[$ii] |= 0xFF & ord shift @str;
push @str, chr(0xFF & ($i>>24)), chr(0xFF & ($i>>16)),
chr(0xFF & ($i>>8)), chr(0xFF & $i);
}
return join '', @str;
}
sub ascii2str { my $a = $_[$[]; # converts pseudo-base64 to string of bytes
local $^W = 0;
$a =~ tr#-A-Za-z0-9+_##cd;
my $ia = $[-1; my $la = length $a; # BUG not length, final!
my $ib = $[; my @b = ();
my $carry;
while (1) { # reads 4 ascii chars and produces 3 bytes
$ia++; last if ($ia>=$la);
$b[$ib] = $a2b{substr $a, $ia+$[, 1}<<2;
$ia++; last if ($ia>=$la);
$carry=$a2b{substr $a, $ia+$[, 1}; $b[$ib] |= ($carry>>4); $ib++;
# if low 4 bits of $carry are 0 and its the last char, then break
$carry = 0xF & $carry; last if ($carry == 0 && $ia == ($la-1));
$b[$ib] = $carry<<4;
$ia++; last if ($ia>=$la);
$carry=$a2b{substr $a, $ia+$[, 1}; $b[$ib] |= ($carry>>2); $ib++;
# if low 2 bits of $carry are 0 and its the last char, then break
$carry = 03 & $carry; last if ($carry == 0 && $ia == ($la-1));
$b[$ib] = $carry<<6;
$ia++; last if ($ia>=$la);
$b[$ib] |= $a2b{substr $a, $ia+$[, 1}; $ib++;
}
return pack 'C*', @b; # 2.16
}
sub str2ascii { my $b = $_[$[]; # converts string of bytes to pseudo-base64
my $ib = $[; my $lb = length $b; my @s = ();
my $b1; my $b2; my $b3;
my $carry;
while (1) { # reads 3 bytes and produces 4 ascii chars
if ($ib >= $lb) { last; };
$b1 = ord substr $b, $ib+$[, 1; $ib++;
push @s, $b2a{$b1>>2}; $carry = 03 & $b1;
if ($ib >= $lb) { push @s, $b2a{$carry<<4}; last; }
$b2 = ord substr $b, $ib+$[, 1; $ib++;
push @s, $b2a{($b2>>4) | ($carry<<4)}; $carry = 0xF & $b2;
if ($ib >= $lb) { push @s, $b2a{$carry<<2}; last; }
$b3 = ord substr $b, $ib+$[, 1; $ib++;
push @s, $b2a{($b3>>6) | ($carry<<2)}, $b2a{077 & $b3};
if (!$ENV{REMOTE_ADDR} && (($ib % 36) == 0)) { push @s, "\n"; }
}
return join('', @s);
}
sub asciidigest { # returns 22-char ascii signature
return binary2ascii(binarydigest($_[$[]));
}
sub binarydigest { my $str = $_[$[]; # returns 4 32-bit-int binary signature
# warning: mode of use invented by Peter Billam 1998, needs checking !
return '' unless $str;
if ($] > 5.007 && Encode::is_utf8($str)) {
Encode::_utf8_off($str);
# $str = Encode::encode_utf8($str);
my $npads = 7 - ((length $str) % 8);
$str = chr($npads|(0xF8 & rand_byte())) . $str;
if ($npads) {
my $padding = pack 'CCCCCCC', rand_byte(), rand_byte(),
rand_byte(), rand_byte(), rand_byte(), rand_byte(), rand_byte();
$str = $str . substr($padding,$[,$npads);
}
my @pblocks = str2binary($str);
my $v0; my $v1;
my $c0 = 0x61626364; my $c1 = 0x62636465; # CBC Initial Value. Retain !
my @cblocks;
push @pblocks, $v0, $v1;
$lastc0 = $c0; $lastc1 = $c1;
}
my $str = binary2str(@pblocks);
# remove no of pad chars at end specified by 1 char ('0'..'7') at front
my $npads = 0x7 & ord $str; substr ($str, $[, 1) = '';
if ($npads) { substr ($str, 0 - $npads) = ''; }
return $str;
}
sub triple_encrypt { my ($plaintext, $long_key) = @_; # not yet ...
}
view all matches for this distribution
view release on metacpan or search on metacpan
_bt/.77CwjdXLFI2Q2Ic :SDZ(GDNc&ymwKdq7p^hbk'@MKUEg]ntSb(a%L)!/VCET8kD7
_u3..o5G7CGXmiVftl0w si(Nb<8@D](~h47m[>+*Wh,k1s7`9o
_JV/.sK/chaBabs.r22w p,C75=:/\CO$b<1N/2sGuu#2%HSp,cBHy}3Ny3$/V
_Fu/.NqA1A3UXZwNqEBM g9__a,ax3"k?wn|CF
_L8..aopATqOIbENUckQ PSI\/&4hqrNJyiuR&p';mAP`/~5$4)d\FfcgSU&hD
_d3/.WrKw/puBiAtrruc l$4ktBjKxG=^qYdw&B#b!^wed!X6ModOot_Q;io8]:&$[F.xJ
_1v..LSxgR45HzV/dWMI -I1?<:Q[}'W:P
_C1...3IJaLhgpP5yl2Q j;H@$Z
_5H0.PjD9w2E.ud.LTIs 7CmnUws(=h*pn;d0=QM9Oj=I
view all matches for this distribution
view release on metacpan or search on metacpan
lib/Ecyrillic.pm view on Meta::CPAN
$slash = 'div';
return $1;
}
# $ $ $ $ $ $ $ $ $ $ $ $ $ $
# $ @ # \ ' " / ? ( ) [ ] < >
elsif (/\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
$slash = 'div';
return $1;
}
# while (<FILEHANDLE>)
lib/Ecyrillic.pm view on Meta::CPAN
$e_string .= $1;
$slash = 'div';
}
# $ $ $ $ $ $ $ $ $ $ $ $ $ $
# $ @ # \ ' " / ? ( ) [ ] < >
elsif ($string =~ /\G ( \$[\$\@\#\\\'\"\/\?\(\)\[\]\<\>] ) /oxmsgc) {
$e_string .= $1;
$slash = 'div';
}
# qq//
view all matches for this distribution
view release on metacpan or search on metacpan
Makefile.PL view on Meta::CPAN
my $cmd = $orig;
my $debug = $::opt_d || $::opt_v;
print "Evaluating `$orig`\n"
if $debug && !$expand_shellescape{$orig};
# ensure we have no $(...) vars left - strip out undefined ones:
$cmd =~ s/\$[({](\w+)[})]/mkvar("$1", 1, 0, $level+1)/ge;
print " expanded `$cmd`\n" if $debug and $cmd ne $orig;
my $result = `$cmd`;
$result =~ s/\s+$/ /; # newlines etc to single space
print " returned '$result'\n"
if $debug && !$expand_shellescape{$orig};
Makefile.PL view on Meta::CPAN
$level ||= 1;
local($_) = $string;
print "$level Expanding $_\n" if $::opt_d;
# handle whizzo AIX make feature used by Oracle
s/\$[({] (\w+) \? ([^(]*?) : ([^(]*?) [})]/
my ($vname, $vT, $vF) = ($1,$2,$3);
$MK{$vname} = (mkvar($vname, 1, $backtick, $level+1)) ? $vT : $vF
/xge; # can recurse
s/\$[({] (\w+) [})]/
mkvar("$1", $strip, $backtick, $level+1, $maxlevel)
/xge; # can recurse
s/`(.*?[^\\])`/expand_shellescape("$1", $level+1)/esg if $backtick; # can recurse
s/\s*\\\n\s*/ /g; # merge continuations
s/\s+/ /g; # shrink whitespace
view all matches for this distribution
view release on metacpan or search on metacpan
lib/DBD/PgPP.pm view on Meta::CPAN
redo Parse;
}
elsif (m{\G( -- [^\n]* )}xmsgc) { }
elsif (m{\G( \' (?> [^\\\']* (?> \\. [^\\\']*)* ) \' )}xmsgc) { }
elsif (m{\G( \" [^\"]* \" )}xmsgc) { }
elsif (m{\G( \s+ | \w+ | ::? | \$[0-9]+ | [-/*\$]
| [^[:ascii:]]+ | [\0-\037\177]+)}xmsgc) { }
elsif (m{\G( [+<>=~!\@\#%^&|`,;.()\[\]{}]+ )}xmsgc) { }
elsif (m{\G( [\'\"\\] )}xmsgc) { } # unmatched: a bug in your query
else {
my $pos = pos;
view all matches for this distribution
view release on metacpan or search on metacpan
lib/DBD/PgPPSjis.pm view on Meta::CPAN
push @tokens, \(my $tmp = $param_num++), '';
redo Parse;
}
# key words, numeric constants, etc
### elsif (m{\G( \s+ | \w+ | ::? | \$[0-9]+ | [-/*\$] | [^[:ascii:]]+ | [\0-\037\177]+ )}xmsgc) {
elsif (m{\G( [\t\n\f\r\x20]+ | [_ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0-9]+ | ::? | \$[0-9]+ | [-/*\$] | (?:$sjis_mbcs|[\x80\xA0-\xDF\xFD-\xFF])+ | [\0-\037\177]+ )}xmsgc) {
}
# operators are + - * / < > = ~ ! @ # % ^ & | ` ?
# special characters are $ ( ) [ ] , ; : * .
elsif (m{\G( [+<>=~!\@\#%^&|`,;.()\[\]{}]+ )}xmsgc) {
view all matches for this distribution
view release on metacpan or search on metacpan
}else if( (flags & JSON_ABPATH) ){
/* The -> and ->> operators accept abbreviated PATH arguments. This
** is mostly for compatibility with PostgreSQL, but also for
** convenience.
**
** NUMBER ==> $[NUMBER] // PG compatible
** LABEL ==> $.LABEL // PG compatible
** [NUMBER] ==> $[NUMBER] // Not PG. Purely for convenience
*/
jsonStringInit(&jx, ctx);
if( sqlite3_value_type(argv[i])==SQLITE_INTEGER ){
jsonAppendRawNZ(&jx, "[", 1);
jsonAppendRaw(&jx, zPath, nPath);
view all matches for this distribution
view release on metacpan or search on metacpan
lib/JSprite.pm view on Meta::CPAN
$errdetails = $i;
return (-525);
}
}
}
#$single = ($#columns) ? $columns[$[] : $column_string;
$single = ($#columns) ? $columns[$#columns] : $column_string;
$rowcnt = 0;
my (@these_results);
my ($skipreformat) = 0;
view all matches for this distribution
view release on metacpan or search on metacpan
cci-src/aclocal.m4 view on Meta::CPAN
[AC_REQUIRE([AC_PROG_CC_C_O])dnl
AC_REQUIRE([AM_AUX_DIR_EXPAND])dnl
# FIXME: we rely on the cache variable name because
# there is no other way.
set dummy $CC
ac_cc=`echo $[2] | sed ['s/[^a-zA-Z0-9_]/_/g;s/^[0-9]/_/']`
if eval "test \"`echo '$ac_cv_prog_cc_'${ac_cc}_c_o`\" != yes"; then
# Losing compiler, so override with the script.
# FIXME: It is wrong to rewrite CC.
# But if we don't then we get into trouble of one sort or another.
# A longer-term fix would be to have automake use am__CC in this case,
cci-src/aclocal.m4 view on Meta::CPAN
# symlink; some systems play weird games with the mod time of symlinks
# (eg FreeBSD returns the mod time of the symlink's containing
# directory).
if (
set X `ls -Lt $srcdir/configure conftest.file 2> /dev/null`
if test "$[*]" = "X"; then
# -L didn't work.
set X `ls -t $srcdir/configure conftest.file`
fi
rm -f conftest.file
if test "$[*]" != "X $srcdir/configure conftest.file" \
&& test "$[*]" != "X conftest.file $srcdir/configure"; then
# If neither matched, then we have a broken ls. This can happen
# if, for instance, CONFIG_SHELL is bash and it inherits a
# broken ls alias from the environment. This has actually
# happened. Such a system could not be considered "sane".
AC_MSG_ERROR([ls -t appears to fail. Make sure there is not a broken
alias in your environment])
fi
test "$[2]" = conftest.file
)
then
# Ok.
:
else
view all matches for this distribution
view release on metacpan or search on metacpan
lib/DBIx/Class/StorageReadOnly/TT.pm view on Meta::CPAN
use tt (subs => [qw/insert update delete/]);
[% FOR sub IN subs %]
{
no warnings 'redefine';
no strict 'refs'; ## no critic
my $[%- sub -%]_code_org = DBIx::Class::Storage::DBI->can('[%- sub -%]');
*{"DBIx\::Class\::Storage\::DBI\::[%- sub -%]"} = sub {
my $self = shift;
if ($self->_search_readonly_info) {
croak("This connection is read only. Can't [%- sub -%].");
}
return $self->$[%- sub -%]_code_org(@_);
};
}
[% END %]
no tt;
view all matches for this distribution
view release on metacpan or search on metacpan
lib/DBIx/Web.pm view on Meta::CPAN
$#_+1 !=2*int(($#_+1)/2)
? 0
: substr($_[$#_],0,1) eq "\n"
? ($n =$_[$#_])
: ($c =$_[$#_]);
((!ref($_[$[+4])
? ('<', $_[$[+4]
,(map {$_[$_]
? (defined($_[$_+1])
? (' ', substr($_[$_],0,1) eq '-' ? substr($_[$_],1) : $_[$_], '="'
, &{$_[$_] ne 'href' ? $_[$[] : $_[$[+1]}
($_[$[+3], !ref($_[$_+1]) ? $_[$_+1] : strdata($_[$[+3], $_[$_+1]))
, '"')
: ())
: eval{$c =$_[$_]; $v =$_[$_+1]; ()}
} map {$_*2+3} $[+1..int(($#_-3)/2) )
,(!defined($c)
? ' />'
: $c eq '0'
? '>'
: ('>'
, (ref($v) eq 'CODE') && ($v =&{$v}) && 0
? ()
: ref($v) eq 'ARRAY'
? &lsTag(@_[$[..$[+3], $v)
: defined($v)
? &{$_[$[+2]}($_[$[+3], $v)
: ()
, '</', $_[$[+4], '>') )
)
: ref($_[$[+4]) eq 'ARRAY'
? (map {ref($_) ne 'ARRAY' ? &{$_[$[+2]}($_[$[+3], $_) : lsTag(@_[$[..$[+3], @$_)} @{$_[$[+4]})
: ref($_[$[+4]) eq 'HASH' && eval{$v =$_[$[+4]; $c =$v->{'-'}||$v->{'-tag'}||'tag'}
? ('<', $c
,(map {defined($v->{$_})
?(' '
, substr($_,0,1) eq '-' ? substr($_, 1) : $_, '="'
, &{$_ ne 'href' ? $_[$[] : $_[$[+1]}
($_[$[+3], !ref($v->{$_}) ? $v->{$_} : strdata($_[$[+3], $v->{$_}))
,'"')
:()
}
sort grep {$_ && $_ !~/^-(tag|data|)$/} keys %$v)
, (grep {exists($v->{$_}) && eval{$v =$v->{$_}}} '', '-data')
? ('>'
,(ref($v) eq 'CODE') && ($v =&{$v}) && 0
? ()
: ref($v) eq 'ARRAY'
? &lsTag(@_[$[..$[+3], $v)
: defined($v)
? &{$_[$[+2]}($_[$[+3], $v)
: ()
,'</',$c,'>')
: exists($v->{0})
? '>'
: ' />'
view all matches for this distribution
view release on metacpan or search on metacpan
lib/DDG/Rewrite.pm view on Meta::CPAN
# out consistently by calling 'sort keys' on the returned hash and 'join' turns
# the sorted keys into a single string.
# e.g. post_body '{"method":"$2","query":"$1","cleaned_query":"$1"}'
# Would give a $cache_keys value of '$1$2'
my $cache_keys = join '', sort keys %{ {
map { $_ => 1 } ( $self->post_body =~ m/\$[0-9]+/g )
} };
$cfg .= "\tproxy_cache_key spice_${spice_name}_$cache_keys;\n"
}
if($uses_echo_module) {
view all matches for this distribution
view release on metacpan or search on metacpan
CAB/Analyzer.pm view on Meta::CPAN
## {details=>$taghvar->{hi}, prob=>($$taghvar->{w}||0), tag=>($$taghvar->{hi} =~ /\[\_?([A-Z0-9]+)\]/ ? \$1 : $$taghvar->{hi})}
sub _am_tagh_fst2moota {
my $taghvar = shift||'$_';
return ("{details=>$taghvar\->{hi},"
." prob=>($taghvar\->{w}||0),"
." tag=>($taghvar\->{hi} =~ /\\[\\_?((?:[A-Za-z0-9\.]+|\\\$[^\\]]+))\\]/ ? \$1 : $taghvar\->{hi})" ##-- allow e.g. [$(] tags from tokenizer!
."} ##-- _am_tagh_fst2moota\n");
}
## PACKAGE::_am_tagh_list2moota($listvar='@{$_->{morph}}')
## + access-closure macro (EXPR): moot token analysis-list from TAGH-style fst analysis-list
view all matches for this distribution