Crypt-SecretBuffer
view release on metacpan or search on metacpan
Version 0.021 - 2026-03-12
- Fix ->save_file(x, 'rename') when the path was a bare filename
- Enhance append_console_line:
- echo "\n" back to console when 'prompt' option is used
- better heuristics for default prompt_fh
- undefined $input_fh now means "the default terminal"
- $input_fh is no longer a required argument
Version 0.020 - 2026-03-08
- Fix bugs in ::PEM->headers (unicode_values, call methods on tied hash)
Version 0.019 - 2026-03-05
- Method 'memcmp' and Span->cmp are now constant-time operations, protecting
against timing attacks when comparing passwords.
- Method ->scan has a new CONST_TIME flag that improves protection against
timing attacks, but needs more work.
- The ::PEM object has an improved design where ->header_kv is the official
array of attributes and 'headers' is a view of that array, providing
features like multi-value, case-insensitivity, and whitespace trimming
without modifying the original array.
Version 0.014 - 2025-12-22
- Fix MULTIPLICITY (ithreads) support
Version 0.013 - 2025-12-21
- New method $span->cmp($other) is like memcmp but on Unicode codepoints
- Span objects now also have overloaded cmp, stringify, and boolean cast
- New PEM parser class
Version 0.012 - 2025-12-19
- String patterns passed to scanning functions (scan, index, rindex, and
various methods of Span) can now be perl unicode strings, or SecretBuffer
objects, or Span objects (with their own encoding) and matches will be
compared codepoint by codepoint.
- Added BASE64 encoding
- New exportable memcmp function, and method of SecretBuffer and Span objects
- Exceptions in unmask_to and unmask_secrets_to now pass through to caller
more correctly.
- SecretBuffer overloads 'cmp' with the new memcmp function, so you can now
compare buffers directly with cmp, lt, gt, eq and so on.
(Span objects do not, yet, to avoid the complicated question of how best to
compare mismatched encodings)
SecretBuffer.h view on Meta::CPAN
* range of characters 0..255 through `s/$patern//g` and building the bitmap
* from the result.
*/
extern secret_buffer_charset * secret_buffer_charset_from_regexpref(SV *ref);
/* Test whether the charset contains an 8-bit byte.
* This relies solely on the bitmap.
*/
extern bool secret_buffer_charset_test_byte(const secret_buffer_charset *cset, U8 b);
/* Test whether the charset contains a unicode character. This uses the perl regex
* engine if the codepoint is higher than 0x7F, to ensure correct matching.
*/
extern bool secret_buffer_charset_test_codepoint(const secret_buffer_charset *cset, U32 cp);
/* encoding flags can be combined with other flags */
#define SECRET_BUFFER_ENCODING_MASK 0xFF
#define SECRET_BUFFER_ENCODING_ISO8859_1 0
#define SECRET_BUFFER_ENCODING_ASCII 1
#define SECRET_BUFFER_ENCODING_UTF8 2
#define SECRET_BUFFER_ENCODING_UTF16LE 3
SecretBuffer.h view on Meta::CPAN
* in which case 'lim' will be updated with the results of the scan.
*
* The _SPAN flag requests that after finding the first match and updating
* 'pos' (or 'lim' if reversed), it will then begin looking for a character not
* belonging to the charset, and then update 'lim'. (or 'pos' if reversed)
*
* If the parse state specifies an encoding, pos and lim must be at character
* boundaries, and invalid characters will stop the parse and store a message
* in ->error, also updating pos (or lim) to indicate the byte offset.
* Note that every codepoint higher than 255 compared to a charset with the
* maybe_unicode flag will call out to the perl regex engine and be a bit slow.
*/
#define SECRET_BUFFER_MATCH_REVERSE 0x0100
#define SECRET_BUFFER_MATCH_NEGATE 0x0200
#define SECRET_BUFFER_MATCH_MULTI 0x0400
#define SECRET_BUFFER_MATCH_ANCHORED 0x0800
#define SECRET_BUFFER_MATCH_CONST_TIME 0x1000
extern bool secret_buffer_match(secret_buffer_parse *p, SV *pattern, int flags);
extern bool secret_buffer_match_charset(secret_buffer_parse *p, secret_buffer_charset *cset, int flags);
extern bool secret_buffer_match_bytestr(secret_buffer_parse *p, char *data, size_t datalen, int flags);
SecretBuffer.xs view on Meta::CPAN
XSRETURN(count);
void
_debug_charset(cset)
secret_buffer_charset *cset
INIT:
HV *hv;
PPCODE:
PUSHs(sv_2mortal((SV*)newRV_noinc((SV*)(hv= newHV()))));
hv_stores(hv, "bitmap", newSVpvn((char*)cset->bitmap, sizeof(cset->bitmap)));
hv_stores(hv, "unicode_above_7F", newSViv(cset->unicode_above_7F));
MODULE = Crypt::SecretBuffer PACKAGE = Crypt::SecretBuffer::AsyncResult
void
wait(result, timeout=-1)
secret_buffer_async_result *result
NV timeout
INIT:
IV os_err, bytes_written;
PPCODE:
lib/Crypt/SecretBuffer.pm view on Meta::CPAN
Eventually, this function may be enhanced with full regex support, but for now
it is limited to one character class and optionally a '+' modifier as an alias
for flag C<MATCH_MULTI>. Until that enhancement occurs, your regex notation must
start with C<[> and must end with either C<]> or C<+>.
($ofs, $len)= $buf->scan(qr/[\w]+/); # implies MATCH_MULTI
The C<$flags> may be a bitwise OR of the L</Match Flags> and one
L<Character Encoding|/Character Encodings>.
Note that C<$ofs> and C<$len> are still byte positions, and still suitable for
L</substr> on the buffer, which is different from Perl's substr on a unicode
string which works in terms of codepoint counts.
For a more convenient interface to this functionality, use L</span> to create a
L<Span object|Crypt::SecretBuffer::Span> and then call its methods.
=head2 memcmp
$cmp= $buf->memcmp($buf2);
Compare contents of the buffer byte-by-byte to another SecretBuffer (or Span, or plain scalar)
lib/Crypt/SecretBuffer.pm view on Meta::CPAN
Display this static string every time the user types a key, for feedback. A common choice would
be C<'*'> or C<'* '>.
=item char_count
Change the completion condition to having added exactly C<$n> characters to the buffer.
The method returns true as soon as this count is reached. Pressing C<Enter> before the
required count is treated as an incomplete read and returns false, even though input was
successfully read.
Note that unicode is not supported yet, so this really means C<$n> bytes.
=item char_max
Stop appending characters when C<$n> have been added to the buffer, but don't return until the
user presses newline. This should only be used with C<char_mask> so that the user can see that
additional keys are not being accepted.
=item char_class
Restrict the permitted characters. This must be a Regexp-ref of a single character class.
Any character the user enters which is not in this class will be ignored and not added to the
buffer.
=back
When using options C<char_mask>, C<char_count>, or C<char_class>, the TTY line-input mode is
disabled and the code processes each character as it is received, manually handling backspace
etc. The code does I<not> handle TTY geometry or unicode, and will display incorrectly if the
user's input reaches the edge of the terminal. This won't usually be a problem if you just
want some fancy handling of N-digit codes where you want to return as soon as they reach the
limit:
$buf->append_console_line(STDIN,
prompt => "PIN: [ ]\b\b\b\b\b\b\b\b\b\b\b\b\b",
char_mask => "* ",
char_count => 6,
char_class => qr/[0-9]/,
);
lib/Crypt/SecretBuffer/PEM/Headers.pm view on Meta::CPAN
if (@_ > 1) {
my $kv= $_[1];
ref $kv eq 'ARRAY' && ($#$kv & 1)
or croak "Expected even-length arrayref";
$_[0]{raw_kv_array}= $kv;
return $_[0];
}
$_[0]{raw_kv_array}
}
sub unicode_keys {
if (@_ > 1) {
$_[0]{unicode_keys}= !!$_[1];
return $_[0];
}
$_[0]{unicode_keys}
}
sub unicode_values {
if (@_ > 1) {
$_[0]{unicode_values}= !!$_[1];
return $_[0];
}
$_[0]{unicode_values}
}
sub trim_keys {
if (@_ > 1) {
$_[0]{trim_keys}= !!$_[1];
return $_[0];
}
$_[0]{trim_keys}
}
sub caseless_keys {
if (@_ > 1) {
$_[0]{caseless_keys}= !!$_[1];
return $_[0];
}
$_[0]{caseless_keys}
}
sub _find_key_idx {
my ($self, $key, $first_only)= @_;
#print "# _find_key_idx($key)\n";
my $kv= $self->{raw_kv_array};
my ($uni, $trim, $fc)= @{$self}{'unicode_keys','trim_keys','caseless_keys'};
my @ret;
if ($uni) {
$key= fc($key) if $fc;
for (0..($#$kv-1)/2) {
my $k= $kv->[$_*2];
utf8::decode($k);
$k =~ s/^\s+// if $trim;
$k =~ s/\s+\z// if $trim;
push(@ret, $_*2) && $first_only && last
if $key eq ($fc? fc($k) : $k);
lib/Crypt/SecretBuffer/PEM/Headers.pm view on Meta::CPAN
}
}
#print "# found at [".join(',', @ret)."]\n";
return \@ret;
}
sub _find_distinct_key_idx {
my $self= shift;
my $kv= $self->{raw_kv_array};
#print "_find_distinct_key_idx raw_kv = [".join(',', @$kv)."]\n";
my ($uni, $trim, $fc)= @{$self}{'unicode_keys','trim_keys','caseless_keys'};
my (@ret, %seen);
for (0..($#$kv-1)/2) {
my $k= $kv->[$_*2];
utf8::decode($k) if $uni;
$k =~ s/^\s+// if $trim;
$k =~ s/\s+\z// if $trim;
push @ret, $_*2
unless $seen{$fc? fc($k) : $k}++;
}
#print "# _find_distinct_key_idx = [".join(',', @ret)."]\n";
lib/Crypt/SecretBuffer/PEM/Headers.pm view on Meta::CPAN
my $kv= $self->{raw_kv_array};
return @{$kv}[@$idxs];
}
sub get_array {
my ($self, $key)= @_;
my $ret= $self->_find_key_idx($key);
my $kv= $self->{raw_kv_array};
$_= $kv->[$_+1] for @$ret;
if ($self->unicode_values) {
utf8::decode($_) for @$ret
}
return $ret;
}
sub get {
my $vals= shift->get_array(@_);
return @$vals > 1? $vals : $vals->[0];
}
lib/Crypt/SecretBuffer/PEM/Headers.pm view on Meta::CPAN
}
}
sub set {
my ($self, $key, $value)= @_;
my $kv= $self->{raw_kv_array};
my $idxs= $self->_find_key_idx($key);
my $idx= shift @$idxs;
if (!defined $idx) {
_validate_new_key($key);
$self->unicode_keys? utf8::encode($key) : utf8::downgrade($key);
} else {
$key= $kv->[$idx];
}
my @ins;
for (ref $value eq 'ARRAY'? @$value : $value) {
_validate_value(my $v= $_);
$self->unicode_values? utf8::encode($v) : utf8::downgrade($v)
unless ref $v;
push @ins, $key, $v;
}
splice(@$kv, $_, 2) for reverse @$idxs;
$idx= @$kv unless defined $idx;
splice(@$kv, $idx, 2, @ins);
$self;
}
sub append {
my ($self, $key, $value)= @_;
_validate_new_key($key);
_validate_value($value);
$self->unicode_keys? utf8::encode($key) : utf8::downgrade($key);
$self->unicode_values? utf8::encode($value) : utf8::downgrade($value)
unless ref $value;
push @{$self->raw_kv_array}, $key, $value;
}
sub delete {
my ($self, $key)= @_;
my $idxs= $self->_find_key_idx($key);
my $kv= $self->{raw_kv_array};
my @ret= map $kv->[$_+1], @$idxs;
lib/Crypt/SecretBuffer/PEM/Headers.pm view on Meta::CPAN
sub Crypt::SecretBuffer::PEM::Headers::_HASH::FETCH { $_[0][0]->get($_[1]) }
sub Crypt::SecretBuffer::PEM::Headers::_HASH::STORE { $_[0][0]->set($_[1], $_[2]) }
sub Crypt::SecretBuffer::PEM::Headers::_HASH::DELETE { $_[0][0]->delete($_[1]) }
sub Crypt::SecretBuffer::PEM::Headers::_HASH::CLEAR { @{ $_[0][0]->raw_kv_array }= () }
sub Crypt::SecretBuffer::PEM::Headers::_HASH::EXISTS { !!@{ $_[0][0]->_find_key_idx($_[1], 1) } }
sub Crypt::SecretBuffer::PEM::Headers::_HASH::FIRSTKEY { $_[0][1]= [ $_[0][0]->keys ]; shift @{$_[0][1]} }
sub Crypt::SecretBuffer::PEM::Headers::_HASH::NEXTKEY { shift @{$_[0][1]} }
# This class is used to bless the tied hash making it both a magic
# hashref and an object with methods.
sub Crypt::SecretBuffer::PEM::Headers::_Proxy::raw_kv_array { tied(%{+shift})->[0]->raw_kv_array(@_) }
sub Crypt::SecretBuffer::PEM::Headers::_Proxy::unicode_keys { tied(%{+shift})->[0]->unicode_keys(@_) }
sub Crypt::SecretBuffer::PEM::Headers::_Proxy::unicode_values { tied(%{+shift})->[0]->unicode_values(@_) }
sub Crypt::SecretBuffer::PEM::Headers::_Proxy::trim_keys { tied(%{+shift})->[0]->trim_keys(@_) }
sub Crypt::SecretBuffer::PEM::Headers::_Proxy::caseless_keys { tied(%{+shift})->[0]->caseless_keys(@_) }
sub Crypt::SecretBuffer::PEM::Headers::_Proxy::keys { tied(%{+shift})->[0]->keys(@_) }
sub Crypt::SecretBuffer::PEM::Headers::_Proxy::get { tied(%{+shift})->[0]->get(@_) }
sub Crypt::SecretBuffer::PEM::Headers::_Proxy::get_array { tied(%{+shift})->[0]->get_array(@_) }
sub Crypt::SecretBuffer::PEM::Headers::_Proxy::set { tied(%{+shift})->[0]->set(@_) }
sub Crypt::SecretBuffer::PEM::Headers::_Proxy::delete { tied(%{+shift})->[0]->delete(@_) }
sub Crypt::SecretBuffer::PEM::Headers::_Proxy::append { tied(%{+shift})->[0]->append(@_) }
# avoid depending on namespace::clean
lib/Crypt/SecretBuffer/PEM/Headers.pm view on Meta::CPAN
$headers= Crypt::SecretBuffer::PEM::Headers->new(%attrs);
=head1 ATTRIBUTES
=head2 raw_kv_array
This is an arrayref of C<< [$key0, $val0, $key1, $val1, ...] >> which was parsed from the PEM
header section, in its original order, capitalization, and byte encoding. The methods of this
object modify the array.
=head2 unicode_keys
If true, assume all keys in L</raw_kv_list> are encoded as UTF-8. Any that aren't will possibly
trigger exceptions, or just not match any attempt to read/write them. Any new keys you add are
expected to be unicode (wide characters) and will be encoded as UTF-8 automatically. If false,
it uses byte matching between the string you supply, and your string must be downgradable to
plain bytes.
=head2 unicode_values
If true, assume all values in L</raw_kv_list> are encoded as UTF-8. Any that aren't will
possibly throw exceptions.
=head2 trim_keys
If true (the default) any leading or trailing whitespace (C<< \s >> in the key name will be
ignored while comparing to the key name you requested. The whitespace remains in the original
KV list for clean round-trips.
lib/Crypt/SecretBuffer/Span.pm view on Meta::CPAN
the buffer without it getting copied into global scalars, which would defeat the purpose of
SecretBuffer. L<https://www.perlmonks.org/?node_id=11166676>.
=head1 CONSTRUCTORS
=head2 new
$span= Crypt::SecretBuffer::Span->new(%attributes);
The only required attribute is C<buf>. C<pos> defaults to 0, C<lim> defaults to the length of
the buffer, and C<encoding> defaults to C<ISO8859_1> which treats each byte as an 8-bit unicode
codepoint.
If called as a method on an object, this behaves the same as L</clone>.
=head2 clone
$span= $span->clone(%attributes);
Create a new span that inherits C<pos>, C<lim>, C<buf>, and C<encoding> from the first span
if they weren't overridden in the attributes.
lib/Crypt/SecretBuffer/Span.pm view on Meta::CPAN
Options:
=over
=item encoding => $encoding
Specify the encoding for the destination. The bytes/characters are read from the current buffer
using the Span's C<encoding> attribute. The default is to assume the same destination encoding
as the source and simply duplicate the byte string, *unless* the destination is a Perl scalar
and the source encoding was a type of unicode, in which case the default is to copy as Perl
"wide characters" (which is internally UTF-8). If you specify UTF-8 here, you will receive
bytes of UTF-8 rather than perl wide characters.
=back
=head2 memcmp
$cmp= $span->memcmp($other_thing);
Compare contents of the span byte-by-byte to another Span (or SecretBuffer, or plain scalar) in
parse_label|5.013007|5.013007|x
parse_listexpr|5.013008|5.013008|x
parse_lparen_question_flags|5.017009||Viu
PARSE_OPTIONAL|5.013007|5.013007|
parser_dup|5.009000|5.009000|u
parser_free|5.009005||Viu
parser_free_nexttoke_ops|5.017006||Viu
parse_stmtseq|5.013006|5.013006|x
parse_subsignature|5.031003|5.031003|x
parse_termexpr|5.013008|5.013008|x
parse_unicode_opts|5.008001||Viu
parse_uniprop_string|5.027011||Viu
PATCHLEVEL|5.003007||Viu
path_is_searchable|5.019001||Vniu
Pause|5.003007||Viu
pause|5.005000||Viu
pclose|5.003007||Viu
peep|5.003007||Viu
pending_ident|5.017004||Viu
PERL_ABS|5.008001|5.003007|p
Perl_acos|5.021004|5.021004|n
PL_threadhook|5.008000||Viu
PL_tmps_floor|5.005000||Viu
PL_tmps_ix|5.005000||Viu
PL_tmps_max|5.005000||Viu
PL_tmps_stack|5.005000||Viu
PL_tokenbuf||5.003007|ponu
PL_top_env|5.005000||Viu
PL_toptarget|5.005000||Viu
PL_TR_SPECIAL_HANDLING_UTF8|5.031006||Viu
PL_underlying_numeric_obj|5.027009||Viu
PL_unicode|5.008001||Viu
PL_unitcheckav|5.009005||Viu
PL_unitcheckav_save|5.009005||Viu
PL_unlockhook|5.007003||Viu
PL_unsafe|5.005000||Viu
PL_UpperLatin1|5.019005||Viu
PLUS|5.003007||Viu
PLUS_t8|5.035004||Viu
PLUS_t8_p8|5.033003||Viu
PLUS_t8_pb|5.033003||Viu
PLUS_tb|5.035004||Viu
#endif
#ifndef PERL_PV_PRETTY_DUMP
# define PERL_PV_PRETTY_DUMP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_QUOTE
#endif
#ifndef PERL_PV_PRETTY_REGPROP
# define PERL_PV_PRETTY_REGPROP PERL_PV_PRETTY_ELLIPSES|PERL_PV_PRETTY_LTGT|PERL_PV_ESCAPE_RE
#endif
/* Hint: pv_escape
* Note that unicode functionality is only backported to
* those perl versions that support it. For older perl
* versions, the implementation will fall back to bytes.
*/
#ifndef pv_escape
#if defined(NEED_pv_escape)
static char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags);
static
#else
extern char * DPPP_(my_pv_escape)(pTHX_ SV * dsv, char const * const str, const STRLEN count, const STRLEN max, STRLEN * const escaped, const U32 flags);
secret_buffer_charset.c view on Meta::CPAN
/* While the compiled Perl regular expression itself will have a character-class (set)
* implementation that could be used directly, its API is private and changes across
* perl versions. I gave up on interfacing directly with that, and took this approach of
* building my own bitmaps.
*
* The bitmaps only cache the result of testing the perl character class against bytes 0-0xFF
* in a non-unicode context. In a unicode context, it uses the cache for codepoints 0-0x7F
* and falls back to invoking the regex engine on each character with a higher codepoint value.
* This is inefficient, but I expect 7-bit ascii or non-unicode context is what gets used the
* most anyway.
*
* This file gets sourced directly into SecretBuffer.xs, so its static functions are availabe
* in other source files as well.
*/
struct secret_buffer_charset {
uint64_t bitmap[4]; // covers 0..255 codepoints
REGEXP *rx; // refers to Regexp object this was derived from
#define SECRET_BUFFER_CHARSET_NOUNI 0
#define SECRET_BUFFER_CHARSET_ALLUNI 1
#define SECRET_BUFFER_CHARSET_TESTUNI 2
int unicode_above_7F; // controls action when matching against unicode
bool match_multi; // stores whether regex ended with '+'
};
/* MAGIC vtable for cached charset */
static int secret_buffer_charset_magic_free(pTHX_ SV *sv, MAGIC *mg) {
if (mg->mg_ptr) {
secret_buffer_charset *cset = (secret_buffer_charset*)mg->mg_ptr;
Safefree(cset);
mg->mg_ptr = NULL;
}
secret_buffer_charset.c view on Meta::CPAN
/* Set a bit in the bitmap */
static inline void sbc_bitmap_set(uint64_t *bitmap, U8 c) {
bitmap[c >> 6] |= (1ULL << (c & 63));
}
/* Test for byte in bitmap */
static inline bool sbc_bitmap_test(const uint64_t *bitmap, U8 c) {
return (bitmap[c >> 6] >> (c & 63)) & 1;
}
/* Helper to test if a unicode codepoint matches the charset */
static bool sbc_test_codepoint(pTHX_ const secret_buffer_charset *cset, U32 cp) {
/* Codepoints 0..7F are cached. Could cache up to 0xFF but locale might mess things up */
if (cp <= 0x80)
return sbc_bitmap_test(cset->bitmap, (U8) cp);
/* High codepoint handling */
if (cset->unicode_above_7F == SECRET_BUFFER_CHARSET_TESTUNI) {
/* Must test with regex engine */
if (!cset->rx) return false;
SV *test_sv= sv_2mortal(newSV(8));
char *utf8_buf= SvPVX(test_sv);
char *end = (char*) uvchr_to_utf8((U8*) utf8_buf, cp);
*end= '\0';
SvPOK_on(test_sv);
SvCUR_set(test_sv, (end - utf8_buf));
SvUTF8_on(test_sv);
I32 result = pregexec(cset->rx, utf8_buf, end, utf8_buf, 0, test_sv, 1);
return result > 0;
}
else
return cset->unicode_above_7F == SECRET_BUFFER_CHARSET_ALLUNI;
}
/* implement extern functions for public API */
bool secret_buffer_charset_test_byte(const secret_buffer_charset *cset, U8 b) {
return sbc_bitmap_test(cset->bitmap, b);
}
bool secret_buffer_charset_test_codepoint(const secret_buffer_charset *cset, U32 cp) {
dTHX;
return sbc_test_codepoint(aTHX_ cset, cp);
}
secret_buffer_charset.c view on Meta::CPAN
/* first character may be ] without ending charset */
if (pos < lim && *pos == ']') {
sbc_bitmap_set(bitmap, ']');
pos++;
}
/* Parse characters and ranges */
while (pos < lim && *pos != ']') {
I32 c= (I32)(unsigned char) *pos++;
int high, low;
// in case of a literal char over 0x7F, things get confusing because I
// can't tell whether the pattern itself is latin-1 or unicode.
if (c >= 0x80)
return false;
// but if ascii notation describes a codepoint over 0x80, that's OK.
else if (c == '\\') {
if (pos >= lim) return false;
switch (*pos++) {
/* is it escaping something we can use literally below? */
case '\\': case ']': case ' ':
c= (unsigned char) pos[-1];
break;
secret_buffer_charset.c view on Meta::CPAN
return false;
++pos;
case '0': case '1': case '2': case '3':
case '4': case '5': case '6': case '7':
c= pos[-1] - '0';
if (pos < lim && *pos >= '0' && *pos <= '7')
c= (c << 3) | (*pos++ - '0');
if (pos < lim && *pos >= '0' && *pos <= '7')
c= (c << 3) | (*pos++ - '0');
if (c > 0xFF)
cset->unicode_above_7F= SECRET_BUFFER_CHARSET_TESTUNI;
break;
case 'x':
if (pos+1 >= lim) return false;
high= HEXCHAR_TO_INT(pos[0]);
low= HEXCHAR_TO_INT(pos[1]);
if (high < 0 || low < 0) return false;
c= (high << 4) | low;
pos += 2;
break;
default:
secret_buffer_charset.c view on Meta::CPAN
return false;
//warn("bitmaps: %08llX %08llX %08llX %08llX\n", bitmap[0], bitmap[1], bitmap[2], bitmap[3]);
if (flag_i) {
// Latin1 case folding will be a mess best handled by the regex engine
if (bitmap[2] | bitmap[3])
return false;
// Bits in range 0x41-0x5A need ORed into 0x61-0x7A and vice-versa
bitmap[1] |= ((bitmap[1]>>32) & 0x7FFFFFE);
bitmap[1] |= (bitmap[1] & 0x7FFFFFE) << 32;
}
// If any char 0x80-0xFF is set, a unicode context should use the regex engine.
// Otherwise, the charset doesn't contain any upper chars at all.
if (bitmap[2] || bitmap[3])
cset->unicode_above_7F= SECRET_BUFFER_CHARSET_TESTUNI;
// Apply negation
if (negated) {
int i;
for (i = 0; i < 4; i++)
bitmap[i] = ~bitmap[i];
if (cset->unicode_above_7F == SECRET_BUFFER_CHARSET_NOUNI)
cset->unicode_above_7F= SECRET_BUFFER_CHARSET_ALLUNI;
}
return true;
}
/* Build bitmap by testing each byte through regex engine */
static void build_charset_via_regex_engine(pTHX_ secret_buffer_charset *cset) {
SV *test_sv= sv_2mortal(newSV(2));
int c;
SvPOK_on(test_sv);
SvCUR_set(test_sv, 1);
secret_buffer_charset.c view on Meta::CPAN
Newxz(cset, 1, secret_buffer_charset);
cset->rx = rx;
if (!parse_simple_charclass(aTHX_ cset, qr_ref)) {
int i;
// reset bitmap
for (i= 0; i < sizeof(cset->bitmap)/sizeof(cset->bitmap[0]); i++)
cset->bitmap[i]= 0;
// Need to use regex engine and cache results of first 256 codepoints.
build_charset_via_regex_engine(aTHX_ cset);
// If pattern has PMf_UNICODE or similar, it might match unicode
//if (rx_flags & (RXf_PMf_LOCALE | RXf_PMf_UNICODE)) {
// ...actually, if 'parse simple' couldn't handle it, need engine regardless
cset->unicode_above_7F= SECRET_BUFFER_CHARSET_TESTUNI;
}
/* Attach magic to cache the charset */
sv_magicext(qr_ref, NULL, PERL_MAGIC_ext,
&secret_buffer_charset_magic_vtbl, (char*)cset, 0);
return cset;
}
secret_buffer_parse.c view on Meta::CPAN
parse->pos= parse->lim;
else
parse->lim= parse->pos;
return !(flags & SECRET_BUFFER_MATCH_NEGATE);
}
/* Remove edge case of zero-length subject (never matches) */
if (parse->pos >= parse->lim) {
return (flags & SECRET_BUFFER_MATCH_NEGATE);
}
/* Since unicode iteration of the pattern is a hassle and might happen lots of times,
* convert it to either plain bytes or array of U32 codepoints.
*/
if (pat_parse.encoding != SECRET_BUFFER_ENCODING_ISO8859_1) {
int dst_enc=
/* these can be transcoded to bytes */
(pat_parse.encoding == SECRET_BUFFER_ENCODING_ASCII
|| pat_parse.encoding == SECRET_BUFFER_ENCODING_HEX
|| pat_parse.encoding == SECRET_BUFFER_ENCODING_BASE64)
? SECRET_BUFFER_ENCODING_ISO8859_1
: SECRET_BUFFER_ENCODING_I32;
secret_buffer_parse.c view on Meta::CPAN
}
else {
// Going to overwrite the scalar, or if its a scalar-ref, overwrite that.
if (SvROK(dst_sv) && !sv_isobject(dst_sv) && SvTYPE(SvRV(dst_sv)) <= SVt_PVMG)
dst_sv= SvRV(dst_sv);
// Refuse to overwrite any other kind of ref
if (SvTYPE(dst_sv) > SVt_PVMG || SvROK(dst_sv)) {
src->error= "Can only copy_to scalars or scalar-refs";
return false;
}
// If the source encoding is a type of unicode, and the destination encoding is not
// specified, then write wide characters (utf-8) to the perl scalar and flag it as utf8
if (encoding < 0 && SECRET_BUFFER_ENCODING_IS_UNICODE(src->encoding)) {
dst.encoding= SECRET_BUFFER_ENCODING_UTF8;
dst_wide= true;
}
}
// Determine how many bytes we need
need_bytes= secret_buffer_sizeof_transcode(src, dst.encoding);
if (need_bytes < 0)
return false;
t/11-index.t view on Meta::CPAN
my @invlist;
for (0..0xFF) {
push @invlist, $_ if vec($_[0], $_, 1) ^ (@invlist & 1);
}
return \@invlist
}
# Test the inversion lists created for various charsets.
# Right now this is converting bitmaps from first 256 bytes into an inversion list,
# but in the future I'd like the back-end to be using inversion lists and able to cover
# unicode.
subtest charset => sub {
# tests below use \x{100} to force perl-interpretation of a regex
# as a baseline to compare the parsed bitmap to the perl-generated one.
my $uni_literal= "\x{1000}";
# third column regards unicode above 0x7F: 0 = none match, 1 = all match, 2 = need to test
my @tests= (
[ qr/[a-z]/ => [97, 123], 0 ],
[ qr/[a-z]/i => [65, 91, 97, 123], 0 ],
($] ge '5.026'? ( # /xx wasn't added until 5.26
[ qr/[a-z 5\x{100}]/ixx => [53, 54, 65, 91, 97, 123], 2 ],
[ qr/[a-z 5]/ixx => [53, 54, 65, 91, 97, 123], 0 ],
):()),
[ do { no warnings; qr/[\0-\108\7777-9]/ } => [0, 9, 55, 58], 2 ],
[ qr/[\t\r\n]/ => [9, 11, 13, 14], 0 ],
[ qr/[[:alpha:]]/ => [65, 91, 97, 123], 2 ],
t/11-index.t view on Meta::CPAN
[ qr/[\p{alpha}\P{alpha}]/ => [ 0 ], 2 ],
[ qr/[^\0\n]/ => [ 1,10, 11 ], 1 ],
);
for (@tests) {
my ($re, $invlist, $above7F)= @$_;
my $cset= Crypt::SecretBuffer::Exports::_debug_charset($re);
$cset->{invlist}= bitmap_to_invlist(delete $cset->{bitmap});
# for now, remove all invlist items greater than 0xFF
pop @{$cset->{invlist}} while 0xFF < ($cset->{invlist}[-1]||0);
pop @$invlist while 0xFF < ($invlist->[-1]||0);
is( $cset, { invlist => $invlist, unicode_above_7F => $above7F }, "$re" );
}
};
subtest index_charset => sub {
my $buf = Crypt::SecretBuffer->new("abc123\0abc456" );
is( $buf->index(qr/[0-9]/), 3, 'find first digit' );
is( $buf->rindex(qr/[0-9]/), 12, 'find last digit' );
is( $buf->index(qr/[a-z]/), 0, 'find first alpha' );
is( $buf->rindex(qr/[a-z]/), 9, 'find last alpha' );
};
subtest scan_charset => sub {
my $str= "abc123\x{100}\x{1000}abc456";
utf8::encode($str);
my $buf = Crypt::SecretBuffer->new($str);
is( [$buf->scan(qr/[0-9]/)], [3,1], 'find digit' );
is( [$buf->scan(qr/[0-9]/, MATCH_MULTI)], [3,3], 'find span of digits' );
is( [$buf->scan(qr/[^a-z0-9]/, UTF8)], [6, 2], 'single char of unicode spans 2 bytes' );
is( [$buf->scan(qr/[^a-z0-9]+/, UTF8)], [6, 5], 'unicode spans 2+3 bytes' );
is( [$buf->scan(qr/[^a-z0-9]/, UTF8|MATCH_REVERSE)], [8, 3], 'second char of unicode spans 3 bytes' );
is( [$buf->scan(qr/[^a-z0-9]+/, UTF8|MATCH_REVERSE)], [6, 5], 'unicode spans 2+3 bytes' );
};
done_testing;
t/30-span.t view on Meta::CPAN
# Copy empty span
my $x;
secret("-")->span(0,0)->copy_to($x);
is( $x, '', 'empty string from empty span' );
secret->span->copy_to($x);
is( $x, '', 'empty string from buffer lacking any storage' );
};
subtest copy_widechar => sub {
my $unicode= "\0\x{10}\x{100}\x{1000}\x{10000}\x{10FFFD}";
my $utf8= encode('UTF-8', $unicode);
my $buf= 'will get overwritten';
secret($utf8)->span(encoding => UTF8)->copy_to($buf);
is( $buf, $unicode, 'round trip through UTF-8' )
or note map escape_nonprintable($_)."\n", $utf8, $buf;
secret($utf8)->span(encoding => UTF8)->append_to($buf);
is( $buf, $unicode x 2, 'round trip through UTF-8, append' )
or note map escape_nonprintable($_)."\n", $utf8, $buf;
my $utf16le= encode('UTF-16LE', $unicode);
$buf= '';
secret($utf16le)->span(encoding => UTF16LE)->copy_to($buf);
is( $buf, $unicode, 'round trip through UTF-16LE' )
or diag explain $buf;
my $utf16be= encode('UTF-16BE', $unicode);
$buf= '';
secret($utf16be)->span(encoding => UTF16BE)->copy_to($buf);
is( $buf, $unicode, 'round trip through UTF-16BE' )
or diag explain $buf;
};
subtest copy_hex => sub {
my $s= secret("\x01\x02\x03");
is( $s->span->copy(encoding => HEX),
object {
call sub { shift->span->starts_with("010203") }, T;
call length => 6;
},
t/30-span.t view on Meta::CPAN
undef $tmp;
secret($b64)->span(encoding => BASE64)->copy_to($tmp, encoding => ISO8859_1);
is( $tmp, $str, "decode $b64" );
}
};
subtest codepointcmp => sub {
is( secret("A")->span cmp secret("B")->span, -1, 'A cmp B' );
is( secret("\xFF")->span cmp "\x{100}", -1, '0xFF cmp 0x100' );
my $unicode= "\0\x{10}\x{100}\x{1000}\x{10000}\x{10FFFD}";
my $utf16= encode('UTF-16LE', $unicode);
is( secret($utf16)->span(encoding => 'UTF16LE') cmp $unicode, 0, 'utf16 cmp utf8' );
};
subtest clean_namespace => sub {
my $ns= \%Crypt::SecretBuffer::Span::;
my @public= qw(
append_to buf buffer can clone cmp consume_bom copy copy_to default_trim_regex encoding
ends_with last_error len length lim ltrim memcmp new parse parse_asn1_der_length
parse_base128be parse_base128le parse_lenprefixed pos rparse rtrim scan set_up_us_the_bom
starts_with subspan trim
);
A => 1,
a => 2,
' A ' => 3,
]
);
is( { %{$pem->headers} }, { A => 1, a => 2, ' A ' => 3 }, 'dump headers hash' );
$pem->headers->caseless_keys(1)->trim_keys(1);
is( { %{$pem->headers} }, { A => [1,2,3] }, 'dump headers hash with casefolding and trim' );
};
subtest header_unicode => sub {
my $canonical= "-----BEGIN SOMETHING-----\n"
. "\xE8\xA9\xA6: -\xE8\xA9\xA6-\n"
. "\n"
. "VGVzdA==\n"
. "-----END SOMETHING-----\n";
my $pem= Crypt::SecretBuffer::PEM->parse(secret($canonical)->span);
is( $pem,
object {
call label => 'SOMETHING';
# should be bytes
call header_kv => [
"\xE8\xA9\xA6", "-\xE8\xA9\xA6-",
];
call headers => object {
call [ unicode_keys => 1 ], T;
call [ unicode_values => 1 ], T;
# should be unicode
call [ get => "\x{8A66}" ] => "-\x{8A66}-";
};
# original scalars should be unchanged
call header_kv => [
"\xE8\xA9\xA6", "-\xE8\xA9\xA6-",
];
call content => object {
call [ memcmp => "VGVzdA==\n" ], 0;
call [ cmp => "Test" ], 0;
};
my %perl_internal= map +($_ => 1), qw( isa can import );
subtest clean_namespace => sub {
my $ns= \%Crypt::SecretBuffer::PEM::;
my @public= qw( buffer content header_kv headers label new parse parse_all serialize );
is( [ grep /^[a-z]/ && !$perl_internal{$_}, sort keys %$ns ], \@public, 'PEM' )
or diag explain $ns;
$ns= \%Crypt::SecretBuffer::PEM::Headers::;
@public= qw( append caseless_keys delete get get_array keys new raw_kv_array set trim_keys
unicode_keys unicode_values );
is( [ grep /^[a-z]/ && !$perl_internal{$_}, sort keys %$ns ], \@public, 'PEM::Headers' )
or diag explain $ns;
};
done_testing;
( run in 1.980 second using v1.01-cache-2.11-cpan-39bf76dae61 )