PC_BASE
=> 36,
PC_TMIN
=> 1,
PC_TMAX
=> 26,
PC_SKEW
=> 38,
PC_DAMP
=> 700,
PC_INITIAL_BIAS
=> 72,
PC_INITIAL_N
=> 128
};
my
$DELIMITER
=
chr
0x2D;
my
%ENTITIES
;
{
open
my
$entities
,
'<'
, catfile(dirname(__FILE__),
'entities.txt'
);
/^(\S+)\s+U\+(\S+)/ and
$ENTITIES
{$1} =
chr
hex
($2)
for
<
$entities
>;
}
my
%REVERSE
= (
"\x{0027}"
=>
'#39;'
);
$REVERSE
{
$ENTITIES
{
$_
}} //=
$_
for
sort
{ @{[
$a
=~ /[A-Z]/g]} <=> @{[
$b
=~ /[A-Z]/g]} }
sort
grep
{/;/}
keys
%ENTITIES
;
my
%CACHE
;
our
@EXPORT_OK
= (
qw(b64_decode b64_encode camelize class_to_file class_to_path decamelize)
,
qw(decode encode get_line hmac_md5_sum hmac_sha1_sum html_escape)
,
qw(html_unescape md5_bytes md5_sum monkey_patch punycode_decode)
,
qw(punycode_encode quote secure_compare sha1_bytes sha1_sum slurp spurt)
,
qw(squish trim unquote url_escape url_unescape xml_escape xor_encode)
);
sub
b64_decode { decode_base64(
$_
[0]) }
sub
b64_encode { encode_base64(
$_
[0],
$_
[1]) }
sub
camelize {
my
$string
=
shift
;
return
$string
if
$string
=~ /^[A-Z]/;
return
join
'::'
,
map
{
join
''
,
map
{
ucfirst
lc
}
split
/_/,
$_
}
split
/-/,
$string
;
}
sub
class_to_file {
my
$class
=
shift
;
$class
=~ s/::|'//g;
$class
=~ s/([A-Z])([A-Z]*)/$1.
lc
($2)/ge;
return
decamelize(
$class
);
}
sub
class_to_path {
join
'.'
,
join
(
'/'
,
split
/::|
'/, shift), '
pm' }
sub
decamelize {
my
$string
=
shift
;
return
$string
if
$string
!~ /^[A-Z]/;
my
@parts
;
for
my
$part
(
split
/::/,
$string
) {
my
@words
;
push
@words
,
lc
$1
while
$part
=~ s/([A-Z]{1}[^A-Z]*)//;
push
@parts
,
join
'_'
,
@words
;
}
return
join
'-'
,
@parts
;
}
sub
decode {
my
(
$encoding
,
$bytes
) =
@_
;
return
undef
unless
eval
{
$bytes
= _encoding(
$encoding
)->decode(
"$bytes"
, 1); 1 };
return
$bytes
;
}
sub
encode { _encoding(
$_
[0])->encode(
"$_[1]"
) }
sub
get_line {
return
undef
if
(
my
$pos
=
index
${
$_
[0]},
"\x0a"
) == -1;
my
$line
=
substr
${
$_
[0]}, 0,
$pos
+ 1,
''
;
$line
=~ s/\x0d?\x0a$//;
return
$line
;
}
sub
hmac_md5_sum { _hmac(\
&md5
,
@_
) }
sub
hmac_sha1_sum { _hmac(\
&sha1
,
@_
) }
sub
html_escape {
my
(
$string
,
$pattern
) =
@_
;
$pattern
||=
'^\n\r\t !#$%(-;=?-~'
;
return
$string
unless
$string
=~ /[^
$pattern
]/;
$string
=~ s/([
$pattern
])/_encode($1)/ge;
return
$string
;
}
sub
html_unescape {
my
$string
=
shift
;
$string
=~ s/&(?:\
return
$string
;
}
sub
md5_bytes { md5(
@_
) }
sub
md5_sum { md5_hex(
@_
) }
sub
monkey_patch {
my
(
$class
,
%patch
) =
@_
;
no
strict
'refs'
;
no
warnings
'redefine'
;
*{
"${class}::$_"
} =
$patch
{
$_
}
for
keys
%patch
;
}
sub
punycode_decode {
my
$input
=
shift
;
my
$n
= PC_INITIAL_N;
my
$i
= 0;
my
$bias
= PC_INITIAL_BIAS;
my
@output
;
if
(
$input
=~ s/(.*)
$DELIMITER
//s) {
push
@output
,
split
//, $1 }
while
(
length
$input
) {
my
$oldi
=
$i
;
my
$w
= 1;
for
(
my
$k
= PC_BASE; 1;
$k
+= PC_BASE) {
my
$digit
=
ord
substr
$input
, 0, 1,
''
;
$digit
=
$digit
< 0x40 ?
$digit
+ (26 - 0x30) : (
$digit
& 0x1f) - 1;
$i
+=
$digit
*
$w
;
my
$t
=
$k
-
$bias
;
$t
=
$t
< PC_TMIN ? PC_TMIN :
$t
> PC_TMAX ? PC_TMAX :
$t
;
last
if
$digit
<
$t
;
$w
*= (PC_BASE -
$t
);
}
$bias
= _adapt(
$i
-
$oldi
,
@output
+ 1,
$oldi
== 0);
$n
+=
$i
/ (
@output
+ 1);
$i
=
$i
% (
@output
+ 1);
splice
@output
,
$i
, 0,
chr
(
$n
);
$i
++;
}
return
join
''
,
@output
;
}
sub
punycode_encode {
my
$output
=
shift
;
my
$len
=
length
$output
;
my
@input
=
map
ord
,
split
//,
$output
;
my
@chars
=
sort
grep
{
$_
>= PC_INITIAL_N }
@input
;
$output
=~ s/[^\x00-\x7f]+//gs;
my
$h
=
my
$b
=
length
$output
;
$output
.=
$DELIMITER
if
$b
> 0;
my
$n
= PC_INITIAL_N;
my
$delta
= 0;
my
$bias
= PC_INITIAL_BIAS;
for
my
$m
(
@chars
) {
next
if
$m
<
$n
;
$delta
+= (
$m
-
$n
) * (
$h
+ 1);
$n
=
$m
;
for
(
my
$i
= 0;
$i
<
$len
;
$i
++) {
my
$c
=
$input
[
$i
];
$delta
++
if
$c
<
$n
;
if
(
$c
==
$n
) {
my
$q
=
$delta
;
for
(
my
$k
= PC_BASE; 1;
$k
+= PC_BASE) {
my
$t
=
$k
-
$bias
;
$t
=
$t
< PC_TMIN ? PC_TMIN :
$t
> PC_TMAX ? PC_TMAX :
$t
;
last
if
$q
<
$t
;
my
$o
=
$t
+ ((
$q
-
$t
) % (PC_BASE -
$t
));
$output
.=
chr
$o
+ (
$o
< 26 ? 0x61 : 0x30 - 26);
$q
= (
$q
-
$t
) / (PC_BASE -
$t
);
}
$output
.=
chr
$q
+ (
$q
< 26 ? 0x61 : 0x30 - 26);
$bias
= _adapt(
$delta
,
$h
+ 1,
$h
==
$b
);
$delta
= 0;
$h
++;
}
}
$delta
++;
$n
++;
}
return
$output
;
}
sub
quote {
my
$string
=
shift
;
$string
=~ s/(["\\])/\\$1/g;
return
qq{"$string"}
;
}
sub
secure_compare {
my
(
$a
,
$b
) =
@_
;
return
undef
if
length
$a
!=
length
$b
;
my
$r
= 0;
$r
|=
ord
(
substr
$a
,
$_
) ^
ord
(
substr
$b
,
$_
)
for
0 ..
length
(
$a
) - 1;
return
$r
== 0;
}
sub
sha1_bytes { sha1(
@_
) }
sub
sha1_sum { sha1_hex(
@_
) }
sub
slurp {
my
$path
=
shift
;
croak
qq{Can't open file "$path": $!}
unless
open
my
$file
, '<',
$path
;
my
$content
=
''
;
while
(
$file
->
sysread
(
my
$buffer
, 131072, 0)) {
$content
.=
$buffer
}
return
$content
;
}
sub
spurt {
my
(
$content
,
$path
) =
@_
;
croak
qq{Can't open file "$path": $!}
unless
open
my
$file
, '>',
$path
;
croak
qq{Can't write to file "$path": $!}
unless
defined
$file
->
syswrite
(
$content
);
return
$content
;
}
sub
squish {
my
$string
= trim(
@_
);
$string
=~ s/\s+/ /g;
return
$string
;
}
sub
trim {
my
$string
=
shift
;
$string
=~ s/^\s+|\s+$//g;
return
$string
;
}
sub
unquote {
my
$string
=
shift
;
return
$string
unless
$string
=~ s/^
"(.*)"
$/$1/g;
$string
=~ s/\\\\/\\/g;
$string
=~ s/\\
"/"
/g;
return
$string
;
}
sub
url_escape {
my
(
$string
,
$pattern
) =
@_
;
$pattern
||=
'^A-Za-z0-9\-._~'
;
$string
=~ s/([
$pattern
])/
sprintf
(
'%%%02X'
,
ord
($1))/ge;
return
$string
;
}
sub
url_unescape {
my
$string
=
shift
;
return
$string
if
index
(
$string
,
'%'
) == -1;
$string
=~ s/%([[:xdigit:]]{2})/
chr
(
hex
($1))/ge;
return
$string
;
}
sub
xml_escape {
my
$string
=
shift
;
$string
=~ s/&/
&
;/g;
$string
=~ s/</
<
;/g;
$string
=~ s/>/
>
;/g;
$string
=~ s/"/
"
;/g;
$string
=~ s/'/&
return
$string
;
}
sub
xor_encode {
my
(
$input
,
$key
) =
@_
;
my
$len
=
length
$key
;
my
$buffer
=
my
$output
=
''
;
$output
.=
$buffer
^
$key
while
length
(
$buffer
=
substr
(
$input
, 0,
$len
,
''
)) ==
$len
;
return
$output
.=
$buffer
^
substr
(
$key
, 0,
length
$buffer
,
''
);
}
sub
_adapt {
my
(
$delta
,
$numpoints
,
$firsttime
) =
@_
;
$delta
=
$firsttime
?
$delta
/ PC_DAMP :
$delta
/ 2;
$delta
+=
$delta
/
$numpoints
;
my
$k
= 0;
while
(
$delta
> ((PC_BASE - PC_TMIN) * PC_TMAX) / 2) {
$delta
/= PC_BASE - PC_TMIN;
$k
+= PC_BASE;
}
return
$k
+ (((PC_BASE - PC_TMIN + 1) *
$delta
) / (
$delta
+ PC_SKEW));
}
sub
_decode {
return
substr
(
$_
[0], 0, 1) eq
'x'
?
chr
(
hex
$_
[0]) :
chr
(
$_
[0])
unless
$_
[1];
my
$rest
=
''
;
my
$entity
=
$_
[1];
while
(
length
$entity
) {
return
"$ENTITIES{$entity}$rest"
if
exists
$ENTITIES
{
$entity
};
$rest
=
chop
(
$entity
) .
$rest
;
}
return
"&$_[1]"
;
}
sub
_encode {
return
exists
$REVERSE
{
$_
[0]} ?
"&$REVERSE{$_[0]}"
:
"&#@{[ord($_[0])]};"
;
}
sub
_encoding {
$CACHE
{
$_
[0]} //= find_encoding(
$_
[0]) // croak
"Unknown encoding '$_[0]'"
;
}
sub
_hmac {
my
(
$hash
,
$string
,
$secret
) =
@_
;
$secret
=
$secret
?
"$secret"
:
'Very insecure!'
;
$secret
=
$hash
->(
$secret
)
if
length
$secret
> 64;
my
$ipad
=
$secret
^ (
chr
(0x36) x 64);
my
$opad
=
$secret
^ (
chr
(0x5c) x 64);
return
unpack
'H*'
,
$hash
->(
$opad
.
$hash
->(
$ipad
.
$string
));
}
1;