Algorithm-MinPerfHashTwoLevel
view release on metacpan or search on metacpan
MinPerfHashTwoLevel.xs view on Meta::CPAN
U64 gf= mph->general_flags;
sv_set_from_bucket(aTHX_ val_sv,strs,bucket->val_ofs,bucket->val_len,index,((U8*)mph)+mph->val_flags_ofs,1,
gf & MPH_VALS_ARE_SAME_UTF8NESS_MASK, MPH_VALS_ARE_SAME_UTF8NESS_SHIFT);
}
return 1;
}
return 0;
}
IV
mph_mmap(pTHX_ char *file, struct mph_obj *obj, SV *error, U32 flags) {
struct stat st;
struct mph_header *head;
int fd = open(file, O_RDONLY, 0);
void *ptr;
U32 alignment;
if (error)
sv_setpvs(error,"");
if (fd < 0) {
if (error)
sv_setpvf(error,"file '%s' could not be opened for read", file);
return MPH_MOUNT_ERROR_OPEN_FAILED;
}
if (fstat(fd,&st)==-1) {
if (error)
sv_setpvf(error,"file '%s' could not be fstat()ed", file);
return MPH_MOUNT_ERROR_FSTAT_FAILED;
}
if (st.st_size < sizeof(struct mph_header)) {
if (error)
sv_setpvf(error,"file '%s' is too small to be a valid PH2L file", file);
return MPH_MOUNT_ERROR_TOO_SMALL;
}
ptr = mmap(NULL, st.st_size, PROT_READ, MAP_SHARED | MPH_MAP_POPULATE, fd, 0);
close(fd); /* kernel holds its own refcount on the file, we do not need to keep it open */
if (ptr == MAP_FAILED) {
if (error)
sv_setpvf(error,"failed to create mapping to file '%s'", file);
return MPH_MOUNT_ERROR_MAP_FAILED;
}
obj->bytes= st.st_size;
obj->header= head= (struct mph_header*)ptr;
if (head->magic_num != MAGIC_DECIMAL) {
if (head->magic_num == MAGIC_BIG_ENDIAN_DECIMAL) {
if (error)
sv_setpvf(error,"this is a big-endian machine, cant handle PH2L files here");
}
if (error)
sv_setpvf(error,"file '%s' is not a PH2L file", file);
return MPH_MOUNT_ERROR_BAD_MAGIC;
}
if (head->variant < MIN_VARIANT) {
if (error)
sv_setpvf(error,"unsupported old version '%d' in '%s'", head->variant, file);
return MPH_MOUNT_ERROR_BAD_VERSION;
}
if (head->variant > MAX_VARIANT) {
if (error)
sv_setpvf(error,"unknown version '%d' in '%s'", head->variant, file);
return MPH_MOUNT_ERROR_BAD_VERSION;
}
alignment = sizeof(U64);
if (st.st_size % alignment) {
if (error)
sv_setpvf(error,"file '%s' does not have a size which is a multiple of 16 bytes", file);
return MPH_MOUNT_ERROR_BAD_SIZE;
}
if (
head->table_ofs < head->state_ofs ||
head->key_flags_ofs < head->table_ofs ||
head->val_flags_ofs < head->key_flags_ofs ||
head->str_buf_ofs < head->val_flags_ofs ||
st.st_size < head->str_buf_ofs
) {
if (error)
sv_setpvf(error,"corrupt header offsets in '%s'", file);
return MPH_MOUNT_ERROR_BAD_OFFSETS;
}
if (flags & MPH_F_VALIDATE) {
char *start= ptr;
char *state_pv= start + head->state_ofs;
char *str_buf_start= start + head->str_buf_ofs;
char *str_buf_end= start + st.st_size;
U64 have_file_checksum= mph_hash_with_state(state_pv, start, st.st_size - sizeof(U64));
U64 want_file_checksum= *((U64 *)(str_buf_end - sizeof(U64)));
if (have_file_checksum != want_file_checksum) {
if (error)
sv_setpvf(error,"file checksum '%016lx' != '%016lx' in file '%s'",
have_file_checksum,want_file_checksum,file);
return MPH_MOUNT_ERROR_CORRUPT_FILE;
}
}
return head->variant;
}
void
mph_munmap(struct mph_obj *obj) {
munmap(obj->header,obj->bytes);
MinPerfHashTwoLevel.xs view on Meta::CPAN
str_buf_pos += sizeof(U64);
SvCUR_set(sv_buf, str_buf_pos - start);
SvPOK_on(sv_buf);
RETVAL= sv_buf;
}
OUTPUT:
RETVAL
SV*
mount_file(file_sv,error_sv,flags)
SV* file_sv
SV* error_sv
U32 flags
PROTOTYPE: $$$
CODE:
{
struct mph_obj obj;
STRLEN file_len;
char *file_pv= SvPV(file_sv,file_len);
IV mmap_status= mph_mmap(aTHX_ file_pv, &obj, error_sv, flags);
if (mmap_status < 0) {
XSRETURN_UNDEF;
}
/* copy obj into a new SV which we can return */
RETVAL= newSVpvn((char *)&obj,sizeof(struct mph_obj));
SvPOK_on(RETVAL);
SvREADONLY_on(RETVAL);
}
OUTPUT:
RETVAL
lib/Tie/Hash/MinPerfHashTwoLevel/OnDisk.pm view on Meta::CPAN
sub mph2l_validate_file {
my ($file, %opts)= @_;
return __PACKAGE__->validate_file(file => $file, %opts);
}
sub new {
my ($class, %opts)= @_;
$opts{flags} ||= 0;
$opts{flags} |= MPH_F_VALIDATE if $opts{validate};
my $error;
my $mount= mount_file($opts{file},$error,$opts{flags});
my $error_rsv= delete $opts{error_rsv};
if ($error_rsv) {
$$error_rsv= $error;
}
if (!defined($mount)) {
if ($error_rsv) {
return;
} else {
die "Failed to mount file '$opts{file}': $error";
}
}
$opts{mount}= $mount;
return bless \%opts, $class;
}
sub TIEHASH {
my ($class, $file, %opts)= @_;
return $class->new( file => $file, %opts );
}
lib/Tie/Hash/MinPerfHashTwoLevel/OnDisk.pm view on Meta::CPAN
return $ofile;
}
sub validate_file {
my ($class, %opts)= @_;
my $file= $opts{file}
or die "file is a mandatory option to validate_file";
my $verbose= $opts{verbose};
my ($variant,$msg);
my $error_sv;
my $self= $class->new(file => $file, flags => MPH_F_VALIDATE, error_rsv => \$error_sv);
if ($self) {
$msg= sprintf "file '%s' is a valid '%s' file\n"
. " variant: %d\n"
. " keys: %d\n"
. " hash-state: %s\n"
. " table checksum: %016x\n"
. " string checksum: %016x\n"
. " comment: %s"
, $file,
MAGIC_STR,
$self->get_hdr_variant,
$self->get_hdr_num_buckets,
unpack("H*", $self->get_state),
$self->get_hdr_table_checksum,
$self->get_hdr_str_buf_checksum,
$self->get_comment,
;
$variant = $self->get_hdr_variant;
} else {
$msg= $error_sv;
}
if ($verbose) {
if (defined $variant) {
print $msg;
} else {
die $msg."\n";
}
}
return ($variant, $msg);
}
lib/Tie/Hash/MinPerfHashTwoLevel/OnDisk.pm view on Meta::CPAN
In version 0.15 we switched hash functions to use SipHash(1-3), which
unfortunately made supporting variants prior to 5 impossible.
=back
=item validate_file
Validate the file specified by the 'file' argument. Returns a list of
two values, 'variant' and 'message'. If the file fails validation the 'variant'
will be undef and the 'message' will contain an error message. If the file
passes validation the 'variant' will specify the variant of the file
(currently only 0 is valid), and 'message' will contain some basic information
about the file, such as how many keys it contains, the comment it was
created with, etc.
=back
=head2 SUBS
=over 4
mph_hv_macro.h view on Meta::CPAN
/* Without a known fast bswap32 we're just as well off doing this */
#define U8TO16_LE(ptr) ((U32)(ptr)[0]|(U32)(ptr)[1]<<8)
#define U8TO32_LE(ptr) ((U32)(ptr)[0]|(U32)(ptr)[1]<<8|(U32)(ptr)[2]<<16|(U32)(ptr)[3]<<24)
#define U8TO64_LE(ptr) ((U64)(ptr)[0]|(U64)(ptr)[1]<<8|(U64)(ptr)[2]<<16|(U64)(ptr)[3]<<24|\
(U64)(ptr)[4]<<32|(U64)(ptr)[5]<<40|\
(U64)(ptr)[6]<<48|(U64)(ptr)[7]<<56)
#endif
#ifdef CAN64BITHASH
#ifndef U64TYPE
/* This probably isn't going to work, but failing with a compiler error due to
lack of uint64_t is no worse than failing right now with an #error. */
#define U64 uint64_t
#endif
#endif
#ifndef ROTL32
/* Find best way to ROTL32/ROTL64 */
#if defined(_MSC_VER)
#include <stdlib.h> /* Microsoft put _rotl declaration in here */
#define ROTL32(x,r) _rotl(x,r)
#define ROTR32(x,r) _rotr(x,r)
--version show version
--patch=file write one patch file with changes
--copy=suffix write changed copies with suffix
--diff=program use diff program and options
--compat-version=version provide compatibility with Perl version
--cplusplus accept C++ comments
--quiet don't output anything except fatal errors
--nodiag don't show diagnostics
--nohints don't show hints
--nochanges don't suggest changes
--nofilter don't filter input files
--strip strip all script and doc functionality
from ppport.h
--list-provided list provided API
--list-unsupported list unsupported API
=head2 --cplusplus
Usually, F<ppport.h> will detect C++ style comments and
replace them with C style comments for portability reasons.
Using this option instructs F<ppport.h> to leave C++
comments untouched.
=head2 --quiet
Be quiet. Don't print anything except fatal errors.
=head2 --nodiag
Don't output any diagnostic messages. Only portability
alerts will be printed.
=head2 --nohints
Don't output any hints. Hints often contain useful portability
notes. Warnings will still be displayed.
PL_copline|5.024000||p
PL_curcop|5.004050||p
PL_curpad||5.005000|
PL_curstash|5.004050||p
PL_debstash|5.004050||p
PL_defgv|5.004050||p
PL_diehook|5.004050||p
PL_dirty|5.004050||p
PL_dowarn|||pn
PL_errgv|5.004050||p
PL_error_count|5.024000||p
PL_expect|5.024000||p
PL_hexdigit|5.005000||p
PL_hints|5.005000||p
PL_in_my_stash|5.024000||p
PL_in_my|5.024000||p
PL_keyword_plugin||5.011002|
PL_last_in_gv|||n
PL_laststatval|5.005000||p
PL_lex_state|5.024000||p
PL_lex_stuff|5.024000||p
PadnameTYPE|||
PadnameUTF8||5.021007|
PadnamelistARRAY||5.024000|
PadnamelistMAX||5.024000|
PadnamelistREFCNT_dec||5.024000|
PadnamelistREFCNT||5.024000|
PerlIO_clearerr||5.007003|
PerlIO_close||5.007003|
PerlIO_context_layers||5.009004|
PerlIO_eof||5.007003|
PerlIO_error||5.007003|
PerlIO_fileno||5.007003|
PerlIO_fill||5.007003|
PerlIO_flush||5.007003|
PerlIO_get_base||5.007003|
PerlIO_get_bufsiz||5.007003|
PerlIO_get_cnt||5.007003|
PerlIO_get_ptr||5.007003|
PerlIO_read||5.007003|
PerlIO_restore_errno|||
PerlIO_save_errno|||
my_nl_langinfo|||n
my_pclose||5.003070|
my_popen_list||5.007001|
my_popen||5.003070|
my_setenv|||
my_snprintf|5.009004||pvn
my_socketpair||5.007003|n
my_sprintf|5.009003||pvn
my_stat_flags|||
my_stat||5.024000|
my_strerror|||
my_strftime||5.007002|
my_strlcat|5.009004||pn
my_strlcpy|5.009004||pn
my_strnlen|||pn
my_strtod|||n
my_unexec|||
my_vsnprintf||5.009004|n
need_utf8|||n
newANONATTRSUB||5.006000|
newANONHASH|||
push_scope|||
put_charclass_bitmap_innards_common|||
put_charclass_bitmap_innards_invlist|||
put_charclass_bitmap_innards|||
put_code_point|||
put_range|||
pv_display|5.006000||p
pv_escape|5.009004||p
pv_pretty|5.009004||p
pv_uni_display||5.007003|
qerror|||
quadmath_format_needed|||n
quadmath_format_single|||n
re_compile||5.009005|
re_croak2|||
re_dup_guts|||
re_exec_indentf|||v
re_indentf|||v
re_intuit_start||5.019001|
re_intuit_string||5.006000|
re_op_compile|||
utf8_distance||5.006000|
utf8_hop_back|||n
utf8_hop_forward|||n
utf8_hop_safe|||n
utf8_hop||5.006000|n
utf8_length||5.007001|
utf8_mg_len_cache_update|||
utf8_mg_pos_cache_update|||
utf8_to_uvchr_buf|5.015009|5.015009|p
utf8_to_uvchr|||p
utf8n_to_uvchr_error|||n
utf8n_to_uvchr||5.007001|n
utf8n_to_uvuni||5.007001|
utilize|||
uvchr_to_utf8_flags||5.007003|
uvchr_to_utf8||5.007001|
uvoffuni_to_utf8_flags||5.019004|
uvuni_to_utf8_flags||5.007003|
uvuni_to_utf8||5.007001|
valid_utf8_to_uvchr|||n
validate_suid|||
warner|5.006000|5.004000|pv
warn|||v
was_lvalue_sub|||
watch|||
whichsig_pvn||5.015004|
whichsig_pv||5.015004|
whichsig_sv||5.015004|
whichsig|||
win32_croak_not_implemented|||n
win32_setlocale|||
with_queued_errors|||
wrap_op_checker||5.015008|
write_to_stderr|||
xs_boot_epilog|||
xs_handshake|||vn
xs_version_bootcheck|||
yyerror_pvn|||
yyerror_pv|||
yyerror|||
yylex|||
yyparse|||
yyquit|||
yyunlex|||
yywarn|||
);
if (exists $opt{'list-unsupported'}) {
my $f;
for $f (sort { lc $a cmp lc $b } keys %API) {
}
my $s = $warnings != 1 ? 's' : '';
my $warn = $warnings ? " ($warnings warning$s)" : '';
info("Analysis completed$warn");
if ($file{changes}) {
if (exists $opt{copy}) {
my $newfile = "$filename$opt{copy}";
if (-e $newfile) {
error("'$newfile' already exists, refusing to write copy of '$filename'");
}
else {
local *F;
if (open F, ">$newfile") {
info("Writing copy of '$filename' with changes to '$newfile'");
print F $c;
close F;
}
else {
error("Cannot open '$newfile' for writing: $!");
}
}
}
elsif (exists $opt{patch} || $opt{changes}) {
if (exists $opt{patch}) {
unless ($patch_opened) {
if (open PATCH, ">$opt{patch}") {
$patch_opened = 1;
}
else {
error("Cannot open '$opt{patch}' for writing: $!");
delete $opt{patch};
$opt{changes} = 1;
goto fallback;
}
}
mydiff(\*PATCH, $filename, $c);
}
else {
fallback:
info("Suggested changes:");
if (!defined $diff) {
$diff = run_diff('diff -u', $file, $str);
}
if (!defined $diff) {
$diff = run_diff('diff', $file, $str);
}
if (!defined $diff) {
error("Cannot generate a diff. Please install Text::Diff or use --copy.");
return;
}
print F $diff;
}
sub run_diff
{
my($prog, $file, $str) = @_;
my $tmp = 'dppptemp';
$diff .= $_;
}
close F;
unlink $tmp;
return $diff;
}
unlink $tmp;
}
else {
error("Cannot open '$tmp' for writing: $!");
}
return undef;
}
sub rec_depend
{
my($func, $seen) = @_;
return () unless exists $depends{$func};
$seen = {%{$seen||{}}};
$opt{quiet} and return;
$opt{diag} and print @_, "\n";
}
sub warning
{
$opt{quiet} and return;
print "*** ", @_, "\n";
}
sub error
{
print "*** ERROR: ", @_, "\n";
}
my %given_hints;
my %given_warnings;
sub hint
{
$opt{quiet} and return;
my $func = shift;
# endif
#endif
#define D_PPP_DEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10))
#define PERL_BCDVERSION ((D_PPP_DEC2BCD(PERL_REVISION)<<24)|(D_PPP_DEC2BCD(PERL_VERSION)<<12)|D_PPP_DEC2BCD(PERL_SUBVERSION))
/* It is very unlikely that anyone will try to use this with Perl 6
(or greater), but who knows.
*/
#if PERL_REVISION != 5
# error ppport.h only works with Perl version 5
#endif /* PERL_REVISION != 5 */
#ifndef dTHR
# define dTHR dNOOP
#endif
#ifndef dTHX
# define dTHX dNOOP
#endif
#ifndef dTHXa
# define dTHXa(x) dNOOP
p++;
return p - str;
}
#endif
#endif
#if (PERL_BCDVERSION < 0x5031002)
/* Versions prior to this accepted things that are now considered
* malformations, and didn't return -1 on error with warnings enabled
* */
# undef utf8_to_uvchr_buf
#endif
/* This implementation brings modern, generally more restricted standards to
* utf8_to_uvchr_buf. Some of these are security related, and clearly must
* be done. But its arguable that the others need not, and hence should not.
* The reason they're here is that a module that intends to play with the
* latest perls shoud be able to work the same in all releases. An example is
* that perl no longer accepts any UV for a code point, but limits them to
*retlen = _ppport_MIN(*retlen, curlen);
}
return UNICODE_REPLACEMENT;
}
else {
/* On versions that correctly detect overflow, but forbid it
* always, 0 will be returned, but also a warning will have been
* raised. Don't repeat it */
if (ret != 0) {
/* We use the error message in use from 5.8-5.14 */
Perl_warner(aTHX_ packWARN(WARN_UTF8),
"Malformed UTF-8 character (overflow at 0x%" UVxf
", byte 0x%02x, after start byte 0x%02x)",
ret, *cur_s, *s);
}
if (retlen) {
*retlen = (STRLEN) -1;
}
return 0;
}
# define PL_compiling compiling
# define PL_copline copline
# define PL_curcop curcop
# define PL_curstash curstash
# define PL_debstash debstash
# define PL_defgv defgv
# define PL_diehook diehook
# define PL_dirty dirty
# define PL_dowarn dowarn
# define PL_errgv errgv
# define PL_error_count error_count
# define PL_expect expect
# define PL_hexdigit hexdigit
# define PL_hints hints
# define PL_in_my in_my
# define PL_laststatval laststatval
# define PL_lex_state lex_state
# define PL_lex_stuff lex_stuff
# define PL_linestr linestr
# define PL_na na
# define PL_perl_destruct_level perl_destruct_level
# define PL_rsfp D_PPP_my_PL_parser_var(rsfp)
# define PL_rsfp_filters D_PPP_my_PL_parser_var(rsfp_filters)
# define PL_linestr D_PPP_my_PL_parser_var(linestr)
# define PL_bufptr D_PPP_my_PL_parser_var(bufptr)
# define PL_bufend D_PPP_my_PL_parser_var(bufend)
# define PL_lex_state D_PPP_my_PL_parser_var(lex_state)
# define PL_lex_stuff D_PPP_my_PL_parser_var(lex_stuff)
# define PL_tokenbuf D_PPP_my_PL_parser_var(tokenbuf)
# define PL_in_my D_PPP_my_PL_parser_var(in_my)
# define PL_in_my_stash D_PPP_my_PL_parser_var(in_my_stash)
# define PL_error_count D_PPP_my_PL_parser_var(error_count)
#else
/* ensure that PL_parser != NULL and cannot be dereferenced */
# define PL_parser ((void *) 1)
#endif
#ifndef mPUSHs
# define mPUSHs(s) PUSHs(sv_2mortal(s))
# else
# define call_sv(sv, flags) ((flags) & G_METHOD ? Perl_call_method(aTHX_ (char *) SvPV_nolen_const(sv), \
(flags) & ~G_METHOD) : Perl_call_sv(aTHX_ sv, flags))
# endif
#endif
/* Replace perl_eval_pv with eval_pv */
#ifndef eval_pv
#if defined(NEED_eval_pv)
static SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error);
static
#else
extern SV* DPPP_(my_eval_pv)(char *p, I32 croak_on_error);
#endif
#if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL)
#ifdef eval_pv
# undef eval_pv
#endif
#define eval_pv(a,b) DPPP_(my_eval_pv)(aTHX_ a,b)
#define Perl_eval_pv DPPP_(my_eval_pv)
SV*
DPPP_(my_eval_pv)(char *p, I32 croak_on_error)
{
dSP;
SV* sv = newSVpv(p, 0);
PUSHMARK(sp);
eval_sv(sv, G_SCALAR);
SvREFCNT_dec(sv);
SPAGAIN;
sv = POPs;
PUTBACK;
if (croak_on_error && SvTRUEx(ERRSV))
croak_sv(ERRSV);
return sv;
}
#endif
#endif
#ifndef vload_module
#if defined(NEED_vload_module)
# define UVof "lo"
# define UVxf "lx"
# define UVXf "lX"
# elif IVSIZE == INTSIZE
# define IVdf "d"
# define UVuf "u"
# define UVof "o"
# define UVxf "x"
# define UVXf "X"
# else
# error "cannot define IV/UV formats"
# endif
#endif
#ifndef NVef
# if defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE) && \
defined(PERL_PRIfldbl) && (PERL_BCDVERSION != 0x5006000)
/* Not very likely, but let's try anyway. */
# define NVef PERL_PRIeldbl
# define NVff PERL_PRIfldbl
# define NVgf PERL_PRIgldbl
t/Corruption.t view on Meta::CPAN
my $fn= sprintf "$tmpdir/test_%03d.mph2l", $pos+1;
open my $ofh, ">", $fn or die "failed to open '$fn' for write: $!";
print $ofh $data;
close $ofh;
substr($data,$pos,1,$chr);
}
ok(1,"constructed files ok");
for my $pos (0 .. length($data)) {
my $fn= sprintf "$tmpdir/test_%03d.mph2l", $pos;
my $got= eval { mph2l_tied_hashref($fn,validate=>1); 1 };
my $error= $got ? "" : "Error: $@";
if ($pos) {
ok( !$got, sprintf "munging offset %d is noticed", $pos-1 );
ok( $error=~/Error: Failed to mount/, sprintf "munging offset %d produces an error of sorts", $pos-1 );
} else {
ok( $got, "loaded base image ok" );
ok ( !$error, "No error loading base image");
}
}
done_testing();
1;
t/OnDisk.pl view on Meta::CPAN
my $class= 'Tie::Hash::MinPerfHashTwoLevel::OnDisk';
plan tests => 2 + 1830 * (defined($ENV{VARIANT}) ? 1 : MAX_VARIANT - MIN_VARIANT + 1);
my $srand= $ENV{SRAND} ? srand(0+$ENV{SRAND}) : srand();
ok(defined($srand),"srand as expected: $srand");
my $eval_ok= eval {
tie my(%fail), $class => $0;
1;
};
my $error= !$eval_ok && $@;
ok($error,"it failed: $@");
my $tmpdir= File::Temp->newdir();
my $not_utf8= "not utf8: \x{DF}";
my $utf8_can_be_downgraded= "was utf8: \x{DF}";
utf8::upgrade($utf8_can_be_downgraded);
my $must_be_utf8= "is utf8: \x{100}"; # this can ONLY be represented as utf8
my @source_hashes= (
simple => {
foo => "bar",
t/OnDisk.pl view on Meta::CPAN
file => $test_file,
source_hash => $source_hash,
comment => $this_comment,
debug => $ENV{TEST_VERBOSE},
seed => \$seed_arg,
variant => $variant,
canonical => $canonical,
);
1;
};
my $error= !$eval_ok && $@;
is($error,"","should be no error ($title)");
ok($eval_ok,"make_file should not die ($title)");
if ($eval_ok) {
if ($corpus_file) {
if (!-e $corpus_file and $ENV{CREATE_CORPUS}) {
require File::Copy;
File::Copy::copy($test_file,$corpus_file);
}
#use File::Copy qw(copy); copy($test_file, $corpus_file);
ok(files_eq($test_file,$corpus_file),"file is as expected ($title)");
}
( run in 0.797 second using v1.01-cache-2.11-cpan-65fba6d93b7 )