Ancient
view release on metacpan or search on metacpan
- Fix C23 bool/true/false compatibility across all XS modules
* Old Perl defines 'bool' but not 'true'/'false' - now handled
* Updated 6 compat headers with proper C23 guards
- Add xt/c-compat.t author test for C standard compatibility
* Checks for C23 keyword conflicts (bool, true, false, nullptr)
* Checks for C89/C99 portability issues
* Checks for unsafe functions (sprintf, strcpy, gets)
* Checks for compiler-specific extensions
0.17 2026-02-03
- object: Add DEMOLISH support for destructor callbacks
* Define DEMOLISH method in class, auto-wrapped DESTROY installed
* Zero overhead: wrapper only installed if DEMOLISH exists
- object: Add Role system for reusable slot/method bundles
* object::role($name, @slots) - define a role with slots
* object::requires($role, @methods) - declare required methods
* object::with($class, @roles) - compose roles into class
* object::does($obj, $role) - check role consumption
* Copies slots and methods, validates required methods
- object: Add Method Modifiers (before/after/around)
* object::before('Class::method', \&callback)
t/1013-booleans.t
t/1014-extended-types.t
t/1015-numeric.t
t/1016-numeric-util.t
t/1017-collections.t
t/1018-trim-maybe.t
t/1019-numeric-string-ops.t
t/1020-specialized-predicates.t
t/1021-final.t
t/1022-stubs.t
t/1023-util-callbacks.t
t/1030-util-predicates-valid.t
t/1031-util-strings-valid.t
t/1032-util-numeric-valid.t
t/1033-util-collections-valid.t
t/1034-util-functional-valid.t
t/1035-util-hof-valid.t
t/1036-util-callbacks-valid.t
t/1037-util-export-registry.t
t/1038-util-export-registry-xs.t
t/1040-util-all-any-none.t
t/1041-util-all-comparisons.t
t/1042-util-any-comparisons.t
t/1043-util-none-comparisons.t
t/1044-util-first-comparisons.t
t/1045-util-final-comparisons.t
t/1046-util-array-hash-ops.t
t/1047-util-bool-negate-force.t
t/1052-util-clamp-minmax-sign.t
t/1053-util-compose-pipeline-partial.t
t/1054-util-always-identity-noop-once.t
t/1055-util-first-final.t
t/1056-util-coalesce-nvl-defaults.t
t/1057-util-dig-lazy-memo.t
t/1058-util-tap-pick-omit-pluck.t
t/1059-util-partition-uniq.t
t/1060-util-stubs.t
t/1061-util-valid-hof.t
t/1062-util-valid-callbacks.t
t/1063-util-valid-comparisons.t
t/1064-util-valid-edge-cases.t
t/1065-map-grep-context.t
t/1066-context-advanced.t
t/1067-context-edge-cases.t
t/1068-cross-module-context.t
t/1070-util-loop-patterns.t
t/1071-clamp.t
t/1072-nvl.t
t/1073-combinators.t
t/1074-omit.t
t/1075-partition.t
t/1076-uniq.t
t/1077-count.t
t/1078-replace_all.t
t/1079-util-callbacks-xs.t
t/1080-util-map-grep-for.t
t/2000-doubly-load.t
t/2001-doubly-odea.t
t/2002-doubly-data.t
t/2003-doubly-start.t
t/2004-doubly-end.t
t/2005-doubly-next.t
t/2006-doubly-prev.t
t/2007-doubly-add.t
t/2008-doubly-insert.t
t/7022-nvec-statistics.t
t/7023-nvec-array-ops.t
t/7024-nvec-float-checks.t
t/7025-nvec-misc.t
t/7026-nvec-quadmath-safety.t
t/7027-nvec-arithmetic-edge.t
t/7028-nvec-numerical-validation.t
t/7029-nvec-loop-patterns.t
t/7030-nvec-random.t
t/8000-file-basic.t
t/8001-file-callbacks.t
t/8002-file-custom-ops.t
t/8003-file-mmap.t
t/8004-file-iterator.t
t/8005-file-edge-cases.t
t/8006-file-platform.t
t/8010-file-mmap-methods.t
t/8011-file-lines-methods.t
t/8012-file-loop-patterns.t
t/8013-file-hooks.t
t/8014-file-xs-api.t
t/9023-leak-util-strings.t
t/9024-leak-util-numeric.t
t/9025-leak-util-collections.t
t/9026-leak-util-hof.t
t/9027-leak-util-functional.t
t/9028-leak-util-boolean.t
t/9029-leak-util-specialized.t
t/9030-leak-object.t
t/9031-leak-heap.t
t/9032-leak-lru.t
t/9033-leak-util-callbacks.t
t/9034-leak-util-misc.t
t/9035-leak-file-lines.t
t/9036-leak-file-mmap.t
t/9037-leak-file-callbacks.t
t/9038-leak-heap-extended.t
t/9039-leak-doubly-ops.t
t/9040-leak-lru-extended.t
t/9041-leak-nvec-extended.t
t/9042-leak-object-extended.t
t/9043-leak-slot-extended.t
t/9044-leak-const-leaktrace.t
t/9045-leak-noop-leaktrace.t
t/9046-leak-file-iterator.t
t/9047-leak-doubly-leaktrace.t
xs/object/object_types.h
xs/object/ppport.h
xs/ppport.h
xs/slot/Makefile.PL
xs/slot/ppport.h
xs/slot/slot.c
xs/slot/slot_compat.h
xs/util/Makefile.PL
xs/util/ppport.h
xs/util/util.c
xs/util/util_callbacks.h
xs/util/util_compat.h
xs/util/util_export.h
xs/vec/vec.c
xs/xop_compat.h
xt/c-compat.t
META.yml Module YAML meta-data (added by MakeMaker)
META.json Module JSON meta-data (added by MakeMaker)
lib/Ancient.pm view on Meta::CPAN
=head2 heap
use heap;
my $pq = heap::new('min');
$pq->push(5)->push(1)->push(3);
print $pq->pop; # 1
Binary heap (priority queue) with configurable min/max behavior.
Supports custom comparison callbacks for complex objects.
O(log n) push and pop, O(1) peek.
See L<heap> for full documentation.
=head2 file
use file;
my $content = file::slurp('data.txt');
file::spew('out.txt', $content);
lib/file.pm view on Meta::CPAN
file::register_line_callback($name, $coderef);
Register a named predicate for line filtering.
file::register_line_callback('is_todo', sub { /TODO|FIXME/ });
# Now use it:
my $todos = file::grep_lines($path, 'is_todo');
=head2 list_line_callbacks
my $names = file::list_line_callbacks();
Returns arrayref of all registered callback names.
Built-in predicates: C<is_blank>, C<is_not_blank>, C<blank>, C<not_blank>,
C<is_empty>, C<is_not_empty>, C<is_comment>, C<is_not_comment>.
=head1 AUTHOR
LNATION
lib/util.pm view on Meta::CPAN
my $expensive = lazy { heavy_computation() };
my $result = force($expensive);
# Safe navigation - no exceptions
my $val = dig($hash, qw(deep nested key));
# Null coalescing
my $val = nvl($maybe_undef, $default);
my $val = coalesce($a, $b, $c); # First defined
# List operations with callbacks
my $found = first(sub { $_->{active} }, \@users);
if (any(sub { $_ > 10 }, \@numbers)) { ... }
if (all(sub { $_->{valid} }, \@records)) { ... }
# Specialized predicates - pure C, no callback overhead
my $large = first_gt(\@numbers, 100); # first > 100
my $adult = first_ge(\@users, 'age', 18); # first user age >= 18
my $last_minor = final_lt(\@users, 'age', 18); # last user age < 18
if (any_gt(\@values, $threshold)) { ... } # any > threshold
if (all_ge(\@scores, 60)) { ... } # all >= 60
lib/util.pm view on Meta::CPAN
eliminate the function call entirely. Useful as a default transformer
in pipelines or when an API requires a function but you want a no-op.
=head2 always
my $get_value = always($constant);
$get_value->(); # Returns $constant
$get_value->(1,2,3); # Still returns $constant (args ignored)
Creates a function that always returns the same value, ignoring any arguments.
Useful for callbacks that need to return a fixed value.
=head2 noop
noop(); # Returns undef
noop(1, 2, 3); # Ignores args, returns undef
Does nothing, returns undef. Ignores all arguments. Useful as a default
callback or placeholder.
B<Note:> This returns C<undef> (not empty list) for correct behavior in
lib/util.pm view on Meta::CPAN
# Check if no element exceeds limit
if (none_gt(\@values, 1000)) { ... }
# Check if no user is a minor
if (none_lt(\@users, 'age', 18)) { ... }
Returns true if no element matches the comparison.
=head1 CALLBACK REGISTRY
The callback registry provides named callbacks that can be used with
the C<*_cb> functions. This avoids Perl callback overhead for common
predicates and enables XS modules to register C-level callbacks for
maximum performance.
=head2 Built-in Predicates
All built-in predicates are prefixed with C<:> to distinguish them
from user-registered callbacks:
:is_defined - SvOK check
:is_true - SvTRUE check
:is_false - !SvTRUE check
:is_ref - SvROK check
:is_array - Array reference
:is_hash - Hash reference
:is_code - Code reference
:is_positive - Numeric > 0
:is_negative - Numeric < 0
lib/util.pm view on Meta::CPAN
Registers a Perl coderef as a named callback. The coderef receives
the element as its first argument. Names cannot start with C<:>
(reserved for built-ins) and cannot re-register existing names.
=head2 has_callback
if (has_callback('divisible_by_3')) { ... }
Returns true if a callback with the given name is registered.
=head2 list_callbacks
my $callbacks = list_callbacks();
Returns an arrayref of all registered callback names.
=head2 XS Callback Registration
External XS modules can register C-level callbacks for maximum performance.
Include the header in your XS code:
#include "util_callbacks.h"
Then register callbacks:
static bool my_is_valid(pTHX_ SV *elem) {
return SvOK(elem) && SvIV(elem) > 0;
}
BOOT:
util_register_predicate_xs("my_is_valid", my_is_valid);
The C callback avoids all Perl overhead - no call_sv, no stack manipulation.
See C<xs/util/util_callbacks.h> for the full API.
=head1 DATA MANIPULATION
These functions transform and extract data from arrays and hashes.
=head2 uniq
my @unique = uniq(@list);
Returns a list with duplicate values removed, preserving order.
t/1023-util-callbacks.t view on Meta::CPAN
# ======================
# count_cb tests
# ======================
is(util::count_cb(\@nums, ':is_positive'), 4, 'count_cb :is_positive = 4');
is(util::count_cb(\@nums, ':is_negative'), 2, 'count_cb :is_negative = 2');
is(util::count_cb(\@nums, ':is_zero'), 1, 'count_cb :is_zero = 1');
is(util::count_cb(\@nums, ':is_even'), 2, 'count_cb :is_even = 2');
is(util::count_cb([], ':is_positive'), 0, 'count_cb empty list = 0');
# ======================
# Type predicate callbacks
# ======================
ok(util::any_cb(\@refs, ':is_array'), 'any_cb :is_array');
ok(util::any_cb(\@refs, ':is_hash'), 'any_cb :is_hash');
ok(util::any_cb(\@refs, ':is_code'), 'any_cb :is_code');
ok(util::any_cb(\@refs, ':is_ref'), 'any_cb :is_ref');
is(util::count_cb(\@refs, ':is_array'), 1, 'count_cb :is_array = 1');
is(util::count_cb(\@refs, ':is_hash'), 1, 'count_cb :is_hash = 1');
is(util::count_cb(\@refs, ':is_code'), 1, 'count_cb :is_code = 1');
is(util::count_cb(\@refs, ':is_ref'), 4, 'count_cb :is_ref = 4');
t/1023-util-callbacks.t view on Meta::CPAN
# ======================
# Custom Perl callback registration
# ======================
util::register_callback('divisible_by_3', sub { $_[0] % 3 == 0 });
ok(util::has_callback('divisible_by_3'), 'custom callback registered');
is(util::count_cb([1..10], 'divisible_by_3'), 3, 'custom callback works');
is_deeply([util::grep_cb([1..10], 'divisible_by_3')], [3, 6, 9], 'grep_cb with custom callback');
# ======================
# list_callbacks
# ======================
my $callbacks = util::list_callbacks();
ok(ref $callbacks eq 'ARRAY', 'list_callbacks returns arrayref');
ok(grep({ $_ eq ':is_positive' } @$callbacks), 'list_callbacks includes :is_positive');
ok(grep({ $_ eq 'divisible_by_3' } @$callbacks), 'list_callbacks includes custom');
# ======================
# Error handling
# ======================
eval { util::any_cb(\@nums, 'nonexistent') };
like($@, qr/unknown callback/, 'unknown callback croaks');
eval { util::any_cb('not_array', ':is_positive') };
like($@, qr/arrayref/, 'non-arrayref croaks');
t/1035-util-hof-valid.t view on Meta::CPAN
first any all none
final
first_gt first_lt first_ge first_le first_eq first_ne
final_gt final_lt final_ge final_le final_eq final_ne
any_gt any_lt any_ge any_le any_eq any_ne
all_gt all_lt all_ge all_le all_eq all_ne
none_gt none_lt none_ge none_le none_eq none_ne
);
# Note: util::count is for counting substrings, not list elements.
# For list counting with callbacks, use count_cb with named predicates.
# Note: first/any/all/none/count take a LIST (not arrayref)
# The specialized predicates (*_gt, *_lt, etc.) take an ARRAYREF
# ============================================
# first - find first matching element
# ============================================
subtest 'first basic' => sub {
my @nums = (1, 2, 3, 4, 5);
t/1036-util-callbacks-valid.t view on Meta::CPAN
use warnings;
use Test::More;
use lib 'blib/lib', 'blib/arch';
use_ok('util');
# util functions are accessed via fully-qualified names since XSLoader
# doesn't set up Exporter
*register_callback = \&util::register_callback;
*has_callback = \&util::has_callback;
*list_callbacks = \&util::list_callbacks;
*any_cb = \&util::any_cb;
*all_cb = \&util::all_cb;
*none_cb = \&util::none_cb;
*first_cb = \&util::first_cb;
*grep_cb = \&util::grep_cb;
*count_cb = \&util::count_cb;
*partition_cb = \&util::partition_cb;
*final_cb = \&util::final_cb;
# ============================================
t/1036-util-callbacks-valid.t view on Meta::CPAN
subtest 'register_callback multiple' => sub {
register_callback('greater_than_5', sub { $_[0] > 5 });
register_callback('less_than_8', sub { $_[0] < 8 });
my $nums = [1, 2, 3, 4, 5, 6, 7, 8, 9, 10];
is_deeply([grep_cb($nums, 'greater_than_5')], [6, 7, 8, 9, 10], 'grep_cb: > 5');
is_deeply([grep_cb($nums, 'less_than_8')], [1, 2, 3, 4, 5, 6, 7], 'grep_cb: < 8');
};
subtest 'list_callbacks' => sub {
my $callbacks = list_callbacks();
ok(ref($callbacks) eq 'ARRAY', 'list_callbacks: returns arrayref');
# Should include built-ins
my %cb_hash = map { $_ => 1 } @$callbacks;
ok($cb_hash{':is_defined'}, 'list_callbacks: has :is_defined');
ok($cb_hash{':is_positive'}, 'list_callbacks: has :is_positive');
ok($cb_hash{':is_even'}, 'list_callbacks: has :is_even');
# Should include our custom ones
ok($cb_hash{'divisible_by_3'}, 'list_callbacks: has divisible_by_3');
ok($cb_hash{'greater_than_5'}, 'list_callbacks: has greater_than_5');
};
# ============================================
# Combining predicates
# ============================================
subtest 'multiple predicate checks' => sub {
my $data = [-10, -5, 0, 5, 10];
# Check positive - grep_cb returns a list
t/1062-util-valid-callbacks.t view on Meta::CPAN
#!/usr/bin/env perl
use strict;
use warnings;
use Test::More;
use lib 't/lib';
use util qw(
any_cb all_cb none_cb first_cb grep_cb count_cb partition_cb final_cb
register_callback has_callback list_callbacks
);
# ============================================
# Callback System Integration Tests
# ============================================
subtest 'built-in predicates - numeric' => sub {
my @numbers = (-5, -2, 0, 1, 3, 5, 8, 10);
# Test with :is_positive
t/1062-util-valid-callbacks.t view on Meta::CPAN
};
subtest 'built-in predicates - string checks' => sub {
my @strings = ('', ' ', 'hello', 'world', undef);
is(count_cb(\@strings, ':is_empty'), 2, 'count empty (undef + "")');
is(count_cb(\@strings, ':is_string'), 4, 'count strings');
};
subtest 'callback registry management' => sub {
# Check built-in callbacks exist
ok(has_callback(':is_positive'), 'has :is_positive');
ok(has_callback(':is_negative'), 'has :is_negative');
ok(has_callback(':is_even'), 'has :is_even');
ok(has_callback(':is_defined'), 'has :is_defined');
# List all callbacks
my $callbacks = list_callbacks();
ok(ref $callbacks eq 'ARRAY', 'list_callbacks returns arrayref');
ok(scalar(@$callbacks) > 10, 'many built-in callbacks');
# Check for expected callbacks in list
my %cb_set = map { $_ => 1 } @$callbacks;
ok($cb_set{':is_positive'}, ':is_positive in list');
ok($cb_set{':is_number'}, ':is_number in list');
};
subtest 'custom callback registration' => sub {
# Register custom callback
register_callback('is_large', sub { $_[0] > 100 });
ok(has_callback('is_large'), 'custom callback registered');
t/1062-util-valid-callbacks.t view on Meta::CPAN
my ($passed, $failed) = partition_cb(\@students, 'passed');
is(scalar(@$passed), 2, 'two passed');
is(scalar(@$failed), 2, 'two failed');
my @passed_names = map { $_->{name} } @$passed;
is_deeply([sort @passed_names], ['Alice', 'Carol'], 'correct students passed');
};
subtest 'chaining callbacks' => sub {
my @data = (-10, -5, 0, 5, 10, 15, 20);
# Find positive numbers, then partition by even/odd
my @positive = grep_cb(\@data, ':is_positive');
my ($evens, $odds) = partition_cb(\@positive, ':is_even');
is_deeply($evens, [10, 20], 'positive evens');
is_deeply($odds, [5, 15], 'positive odds');
};
t/1062-util-valid-callbacks.t view on Meta::CPAN
subtest 'real-world: data filtering pipeline' => sub {
my @transactions = (
{ amount => 100, type => 'credit' },
{ amount => -50, type => 'debit' },
{ amount => 200, type => 'credit' },
{ amount => -30, type => 'debit' },
{ amount => 0, type => 'adjustment' },
);
# Register callbacks for transaction filtering
register_callback('is_credit', sub { $_[0]->{type} eq 'credit' });
register_callback('is_debit', sub { $_[0]->{type} eq 'debit' });
register_callback('non_zero', sub { $_[0]->{amount} != 0 });
my @credits = grep_cb(\@transactions, 'is_credit');
is(scalar(@credits), 2, 'two credits');
my @debits = grep_cb(\@transactions, 'is_debit');
is(scalar(@debits), 2, 'two debits');
my @active = grep_cb(\@transactions, 'non_zero');
is(scalar(@active), 4, 'four non-zero transactions');
# Calculate totals
my $credit_total = 0;
$credit_total += $_->{amount} for @credits;
is($credit_total, 300, 'credit total = 300');
};
subtest 'real-world: validation framework' => sub {
# Register validation callbacks
register_callback('has_name', sub { defined $_[0]->{name} && length($_[0]->{name}) > 0 });
register_callback('has_email', sub { defined $_[0]->{email} && $_[0]->{email} =~ /@/ });
register_callback('adult', sub { defined $_[0]->{age} && $_[0]->{age} >= 18 });
my @users = (
{ name => 'Alice', email => 'alice@example.com', age => 25 },
{ name => 'Bob', age => 17 },
{ name => '', email => 'anon@example.com', age => 30 },
{ name => 'Carol', email => 'carol@example.com', age => 22 },
);
t/1064-util-valid-edge-cases.t view on Meta::CPAN
#!/usr/bin/env perl
use strict;
use warnings;
use Test::More;
use lib 't/lib';
use util qw(
list_callbacks has_callback register_callback
is_between clamp sign maybe
stub_true stub_false stub_array stub_hash stub_string stub_zero
force lazy memo
);
# first_inline requires MULTICALL API (Perl 5.11+)
my $has_first_inline = $] >= 5.011 && util->can('first_inline');
if ($has_first_inline) {
util->import('first_inline');
}
t/1064-util-valid-edge-cases.t view on Meta::CPAN
ok(!defined $found, 'first_inline on empty list returns undef');
# Complex condition
my @data = ({ val => 1 }, { val => 5 }, { val => 10 });
$found = first_inline(sub { $_->{val} > 3 }, @data);
is_deeply($found, { val => 5 }, 'first_inline with complex condition');
};
}
subtest 'callback registry - list and management' => sub {
# List all built-in callbacks
my $callbacks = list_callbacks();
ok(ref $callbacks eq 'ARRAY', 'list_callbacks returns arrayref');
# Check for standard built-in callbacks
my %cb_set = map { $_ => 1 } @$callbacks;
ok($cb_set{':is_positive'}, 'has :is_positive');
ok($cb_set{':is_negative'}, 'has :is_negative');
ok($cb_set{':is_zero'}, 'has :is_zero');
ok($cb_set{':is_even'}, 'has :is_even');
ok($cb_set{':is_odd'}, 'has :is_odd');
ok($cb_set{':is_defined'}, 'has :is_defined');
ok($cb_set{':is_true'}, 'has :is_true');
ok($cb_set{':is_false'}, 'has :is_false');
ok($cb_set{':is_ref'}, 'has :is_ref');
ok($cb_set{':is_array'}, 'has :is_array');
t/1064-util-valid-edge-cases.t view on Meta::CPAN
# has_callback for built-ins
ok(has_callback(':is_positive'), 'has_callback :is_positive');
ok(has_callback(':is_number'), 'has_callback :is_number');
ok(!has_callback('nonexistent_xyz_123'), 'has_callback returns false for unknown');
# Register custom callback
register_callback('test_custom_64', sub { $_[0] > 64 });
ok(has_callback('test_custom_64'), 'custom callback registered');
# Verify it appears in list
my $new_list = list_callbacks();
my %new_set = map { $_ => 1 } @$new_list;
ok($new_set{'test_custom_64'}, 'custom callback in list');
};
subtest 'is_between - range checking' => sub {
# Basic range checks
ok(is_between(5, 1, 10), '5 is between 1 and 10');
ok(is_between(1, 1, 10), '1 is between 1 and 10 (inclusive)');
ok(is_between(10, 1, 10), '10 is between 1 and 10 (inclusive)');
ok(!is_between(0, 1, 10), '0 is not between 1 and 10');
t/1064-util-valid-edge-cases.t view on Meta::CPAN
# Use maybe for optional debug
my $debug_level = maybe($config->{debug}, 3);
is($debug_level, 3, 'debug level set');
# Sign for direction indicators
my $trend = -15;
is(sign($trend), -1, 'negative trend indicator');
};
subtest 'real-world: data pipeline with stubs' => sub {
# Use stubs as default callbacks
my $on_success = stub_true(); # Always succeeds
my $on_error = stub_false(); # Always fails
# Simulate processing
my @results;
for my $item (1, 2, 3) {
if ($on_success) {
push @results, $item * 2;
}
}
t/1079-util-callbacks-xs.t view on Meta::CPAN
subtest 'Invalid arguments' => sub {
eval { util::any_cb('not_array', ':is_positive') };
like($@, qr/arrayref/, 'any_cb requires arrayref');
eval { util::any_cb({}, ':is_positive') };
like($@, qr/arrayref/, 'any_cb rejects hashref');
};
# ============================================
# Test list_callbacks returns all
# ============================================
subtest 'list_callbacks' => sub {
my $callbacks = util::list_callbacks();
ok(ref $callbacks eq 'ARRAY', 'returns arrayref');
# Should have all built-ins
my %cb = map { $_ => 1 } @$callbacks;
ok($cb{':is_defined'}, 'has :is_defined');
ok($cb{':is_positive'}, 'has :is_positive');
ok($cb{':is_array'}, 'has :is_array');
ok($cb{':is_even'}, 'has :is_even');
ok($cb{'is_long_string'}, 'has user-registered callback');
};
# ============================================
# Test has_callback
# ============================================
t/1080-util-map-grep-for.t view on Meta::CPAN
subtest 'min2/max2 in map' => sub {
my @pairs = ([1, 5], [3, 2], [7, 7], [0, 10]);
my @mins = map { min2($_->[0], $_->[1]) } @pairs;
my @maxs = map { max2($_->[0], $_->[1]) } @pairs;
is_deeply(\@mins, [1, 2, 7, 0], 'min2 in map');
is_deeply(\@maxs, [5, 3, 7, 10], 'max2 in map');
};
# ============================================
# Collection functions with callbacks in map/grep
# ============================================
subtest 'first in map over arrays' => sub {
my @arrays = ([1, 2, 3], [10, 20, 30], [5, 15, 25]);
# first takes a list, not arrayref - use @$_ to flatten
my @firsts = map { first(sub { $_ > 5 }, @$_) } @arrays;
is_deeply(\@firsts, [undef, 10, 15], 'first with callback in map');
};
subtest 'any in map over arrays' => sub {
t/2039-doubly-deadlock.t view on Meta::CPAN
my $list = doubly->new();
$list->bulk_add(1, 3, 5, 7, 9);
# Insert 2 before the first element > 2
$list->insert(sub { $_[0] > 2 }, 2);
}, 'insert callback');
ok($ok, 'Insert callback completed without deadlock');
};
# Test 6: Mixed nested and callbacks
subtest 'No deadlock with nested objects in find' => sub {
plan tests => 1;
my $ok = with_timeout(5, sub {
my $list = doubly->new();
for my $i (1..10) {
my $inner = doubly->new();
$inner->add({ id => $i, name => "item_$i" });
$list->add($inner);
t/4006-object-types-custom.t view on Meta::CPAN
# if (!SvIOK(val) && !looks_like_number(val)) return false;
# return SvIV(val) > 0;
# }
#
# BOOT:
# object_register_type_xs(aTHX_ "PositiveInt", check_positive_int, NULL);
#
# The registered C function is called directly from the setter op
# with no Perl callback overhead (~5 cycles vs ~100 cycles)
# For now, test with Perl callbacks (same flow, different overhead)
object::register_type('PositiveInt', sub {
my $val = shift;
return defined($val) && $val =~ /^-?\d+$/ && $val > 0;
});
object::register_type('NonEmptyStr', sub {
my $val = shift;
return defined($val) && !ref($val) && length($val) > 0;
});
t/8001-file-callbacks.t view on Meta::CPAN
my $r2 = file::grep_lines($test_file, 'custom_test');
is(scalar(@$r2), 9, 'replaced callback matches all');
};
subtest 'register_line_callback requires coderef' => sub {
eval { file::register_line_callback('bad', 'not a coderef') };
like($@, qr/coderef/, 'dies without coderef');
};
# ============================================
# list_line_callbacks tests
# ============================================
subtest 'list_line_callbacks' => sub {
my $list = file::list_line_callbacks();
is(ref($list), 'ARRAY', 'returns arrayref');
# Check builtins exist
my %callbacks = map { $_ => 1 } @$list;
ok($callbacks{'is_blank'}, 'is_blank registered');
ok($callbacks{'is_not_blank'}, 'is_not_blank registered');
ok($callbacks{'is_empty'}, 'is_empty registered');
ok($callbacks{'is_not_empty'}, 'is_not_empty registered');
ok($callbacks{'is_comment'}, 'is_comment registered');
ok($callbacks{'is_not_comment'}, 'is_not_comment registered');
# Aliases
ok($callbacks{'blank'}, 'blank alias registered');
ok($callbacks{'not_blank'}, 'not_blank alias registered');
};
# ============================================
# Edge cases and stress tests
# ============================================
subtest 'callback with die' => sub {
eval {
file::each_line($test_file, sub {
die "intentional error" if shift eq 'cherry';
});
};
like($@, qr/intentional error/, 'callback die propagates');
};
subtest 'large file callbacks' => sub {
my $large = "$tmpdir/large_callback.txt";
my @lines = map { "line number $_" } 1..1000; # Reduced from 10000
file::spew($large, join("\n", @lines));
my $count = 0;
file::each_line($large, sub { $count++ });
is($count, 1000, 'processes all 1000 lines');
my $filtered = file::grep_lines($large, sub { /555/ });
ok(scalar(@$filtered) > 0, 'grep works on large file');
t/9006-leak-util-hof-leak.t view on Meta::CPAN
});
test_no_leak("stub_string", sub {
my $r = stub_string();
});
test_no_leak("stub_zero", sub {
my $r = stub_zero();
});
# Test first/any/all/none with callbacks using & prototype
my @nums = (1, 2, 3, 4, 5);
test_no_leak("first with callback", sub {
my $r = first(sub { $_ > 2 }, @nums);
});
test_no_leak("any with callback", sub {
my $r = any(sub { $_ > 2 }, @nums);
});
test_no_leak("all with callback", sub {
t/9033-leak-util-callbacks.t view on Meta::CPAN
use Test::More;
BEGIN {
eval { require Test::LeakTrace };
plan skip_all => 'Test::LeakTrace required' if $@;
}
use Test::LeakTrace;
use util qw(
any_cb all_cb none_cb first_cb grep_cb count_cb partition_cb final_cb
register_callback has_callback list_callbacks
);
# Test data - create outside of leak tests
my @numbers = (-5, -2, 0, 1, 3, 5, 8, 10, 12);
my @mixed = (undef, "", 0, 1, "hello", [], {});
# Warmup
for (1..10) {
any_cb(\@numbers, ':is_positive');
all_cb(\@numbers, ':is_defined');
first_cb(\@numbers, ':is_zero');
}
# ==== Built-in predicate callbacks ====
subtest 'any_cb with built-in predicates' => sub {
no_leaks_ok {
for (1..500) {
my $r1 = any_cb(\@numbers, ':is_positive');
my $r2 = any_cb(\@numbers, ':is_negative');
my $r3 = any_cb(\@numbers, ':is_zero');
my $r4 = any_cb(\@numbers, ':is_even');
my $r5 = any_cb(\@numbers, ':is_odd');
}
t/9033-leak-util-callbacks.t view on Meta::CPAN
subtest 'has_callback' => sub {
no_leaks_ok {
for (1..1000) {
my $r1 = has_callback(':is_positive');
my $r2 = has_callback(':is_defined');
my $r3 = has_callback('nonexistent_callback');
}
} 'has_callback does not leak';
};
subtest 'list_callbacks' => sub {
no_leaks_ok {
for (1..500) {
my $callbacks = list_callbacks();
}
} 'list_callbacks does not leak';
};
# ==== User-registered callbacks ====
# Register a custom callback once before testing
eval { register_callback('is_big', sub { $_[0] > 5 }) };
subtest 'register_callback usage' => sub {
plan skip_all => 'Custom callback not registered' unless has_callback('is_big');
no_leaks_ok {
for (1..500) {
my $r1 = any_cb(\@numbers, 'is_big');
my $r2 = first_cb(\@numbers, 'is_big');
my $r3 = count_cb(\@numbers, 'is_big');
}
} 'custom callback usage does not leak';
};
# ==== More built-in predicates ====
subtest 'type predicates via callbacks' => sub {
no_leaks_ok {
for (1..500) {
my $r1 = any_cb(\@mixed, ':is_array');
my $r2 = any_cb(\@mixed, ':is_hash');
my $r3 = any_cb(\@mixed, ':is_ref');
my $r4 = first_cb(\@mixed, ':is_string');
}
} 'type predicates via callbacks do not leak';
};
subtest 'truthiness predicates via callbacks' => sub {
no_leaks_ok {
for (1..500) {
my $r1 = any_cb(\@mixed, ':is_true');
my $r2 = any_cb(\@mixed, ':is_false');
my $r3 = count_cb(\@mixed, ':is_defined');
my $r4 = count_cb(\@mixed, ':is_empty');
}
} 'truthiness predicates via callbacks do not leak';
};
done_testing();
t/9037-leak-file-callbacks.t view on Meta::CPAN
};
subtest 'register_line_callback no leak' => sub {
no_leaks_ok {
for (1..100) {
file::register_line_callback("test_cb_$_", sub { 1 });
}
} 'register_line_callback does not leak';
};
subtest 'list_line_callbacks no leak' => sub {
no_leaks_ok {
for (1..200) {
my $list = file::list_line_callbacks();
}
} 'list_line_callbacks does not leak';
};
done_testing();
xs/file/file.c view on Meta::CPAN
croak("Second argument must be a code reference");
}
block_cv = (CV*)SvRV(callback);
idx = file_lines_open(aTHX_ path);
if (idx < 0) {
XSRETURN_EMPTY;
}
/* Process each line with the callback */
/* Set both $_ and pass as argument so callbacks can use either style */
{
SV *old_defsv = DEFSV;
SAVESPTR(DEFSV); /* Automatically restore $_ on scope exit */
while ((line = file_lines_next(aTHX_ idx)) != &PL_sv_undef) {
dSP;
ENTER;
SAVETMPS;
DEFSV_set(line); /* Set $_ */
PUSHMARK(SP);
xs/file/file.c view on Meta::CPAN
Newxz(cb, 1, FileLineCallback);
cb->predicate = NULL; /* No C function */
cb->perl_callback = newSVsv(coderef);
sv = newSViv(PTR2IV(cb));
hv_store(g_file_callback_registry, name, name_len, sv, 0);
XSRETURN_YES;
}
/* List registered callbacks */
static XS(xs_list_line_callbacks) {
dXSARGS;
AV *result;
HE *entry;
PERL_UNUSED_VAR(items);
result = newAV();
if (g_file_callback_registry) {
hv_iterinit(g_file_callback_registry);
while ((entry = hv_iternext(g_file_callback_registry))) {
xs/file/file.c view on Meta::CPAN
SV *coderef;
FileHookEntry *entry;
if (items != 1) croak("Usage: file::register_read_hook(\\&coderef)");
coderef = ST(0);
if (!SvROK(coderef) || SvTYPE(SvRV(coderef)) != SVt_PVCV) {
croak("file::register_read_hook: argument must be a coderef");
}
/* Use the hook list for Perl callbacks */
Newxz(entry, 1, FileHookEntry);
entry->name = "perl_read_hook";
entry->c_func = NULL;
entry->perl_callback = newSVsv(coderef);
entry->priority = FILE_HOOK_PRIORITY_NORMAL;
entry->user_data = NULL;
entry->next = g_file_hooks[FILE_HOOK_PHASE_READ];
g_file_hooks[FILE_HOOK_PHASE_READ] = entry;
XSRETURN_YES;
xs/file/file.c view on Meta::CPAN
SV *coderef;
FileHookEntry *entry;
if (items != 1) croak("Usage: file::register_write_hook(\\&coderef)");
coderef = ST(0);
if (!SvROK(coderef) || SvTYPE(SvRV(coderef)) != SVt_PVCV) {
croak("file::register_write_hook: argument must be a coderef");
}
/* Use the hook list for Perl callbacks */
Newxz(entry, 1, FileHookEntry);
entry->name = "perl_write_hook";
entry->c_func = NULL;
entry->perl_callback = newSVsv(coderef);
entry->priority = FILE_HOOK_PRIORITY_NORMAL;
entry->user_data = NULL;
entry->next = g_file_hooks[FILE_HOOK_PHASE_WRITE];
g_file_hooks[FILE_HOOK_PHASE_WRITE] = entry;
XSRETURN_YES;
xs/file/file.c view on Meta::CPAN
}
/* Functions without custom op optimization */
newXS("file::join", xs_join, __FILE__);
newXS("file::each_line", xs_each_line, __FILE__);
newXS("file::grep_lines", xs_grep_lines, __FILE__);
newXS("file::count_lines", xs_count_lines, __FILE__);
newXS("file::find_line", xs_find_line, __FILE__);
newXS("file::map_lines", xs_map_lines, __FILE__);
newXS("file::register_line_callback", xs_register_line_callback, __FILE__);
newXS("file::list_line_callbacks", xs_list_line_callbacks, __FILE__);
/* File hooks */
newXS("file::register_read_hook", xs_register_read_hook, __FILE__);
newXS("file::register_write_hook", xs_register_write_hook, __FILE__);
newXS("file::clear_hooks", xs_clear_hooks, __FILE__);
newXS("file::has_hooks", xs_has_hooks, __FILE__);
/* Head and tail */
newXS("file::head", xs_head, __FILE__);
newXS("file::tail", xs_tail, __FILE__);
xs/file/file_hooks.h view on Meta::CPAN
} FileHookPriority;
/* Hook phases */
typedef enum {
FILE_HOOK_PHASE_READ, /* After reading, before returning */
FILE_HOOK_PHASE_WRITE, /* Before writing */
FILE_HOOK_PHASE_OPEN, /* Before opening file */
FILE_HOOK_PHASE_CLOSE /* After closing file */
} FileHookPhase;
/* Hook context passed to callbacks */
typedef struct {
const char *path; /* File path */
SV *data; /* Data SV (may be modified in place) */
FileHookPhase phase; /* Which phase */
void *user_data; /* User-provided context */
int cancel; /* Set to 1 to cancel operation */
} FileHookContext;
/*
* C hook function signature
xs/object/object.c view on Meta::CPAN
case TYPE_BOOL: return "Bool";
case TYPE_ARRAYREF: return "ArrayRef";
case TYPE_HASHREF: return "HashRef";
case TYPE_CODEREF: return "CodeRef";
case TYPE_OBJECT: return "Object";
case TYPE_CUSTOM: return "custom";
default: return "unknown";
}
}
/* Check a value against a slot's type constraint (handles both C and Perl callbacks) */
static bool check_slot_type(pTHX_ SV *val, SlotSpec *spec) {
if (!spec || !spec->has_type) return true;
if (spec->type_id != TYPE_CUSTOM) {
return check_builtin_type(aTHX_ val, spec->type_id);
}
if (!spec->registered) return true;
/* Try C function first (fast path - ~5 cycles) */
xs/object/object.c view on Meta::CPAN
SPAGAIN;
val = POPs;
PUTBACK;
}
/* External XS type coercion (C function - fast path) */
if (spec->type_id == TYPE_CUSTOM && spec->registered && spec->registered->coerce) {
val = spec->registered->coerce(aTHX_ val);
}
/* Type check using helper (handles both C and Perl callbacks) */
if (spec->has_type) {
if (!check_slot_type(aTHX_ val, spec)) {
const char *type_name = (spec->type_id == TYPE_CUSTOM && spec->registered)
? spec->registered->name
: type_id_to_name(spec->type_id);
croak("Type constraint failed for '%s': expected %s",
spec->name, type_name);
}
}
xs/object/object_types.h view on Meta::CPAN
* use object;
*
* object::define('User',
* 'age:PositiveInt', # Uses C function directly - ~5 cycles
* 'email:Email', # Uses C function directly - ~5 cycles
* );
*
* Performance comparison:
* - Built-in types (Str, Int): ~0 cycles (inline switch)
* - Registered C functions: ~5 cycles (function pointer call)
* - Perl callbacks: ~100 cycles (call_sv overhead)
*/
#ifndef OBJECT_TYPES_H
#define OBJECT_TYPES_H
#include "EXTERN.h"
#include "perl.h"
/*
* Type check function signature.
xs/slot/slot.c view on Meta::CPAN
IV idx = PL_op->op_targ;
SV *callback = POPs;
char key[32];
int klen = snprintf(key, sizeof(key), "%ld", (long)idx);
SV **name_svp = hv_fetch(g_slot_names, key, klen, 0);
if (name_svp) {
STRLEN name_len;
const char *name = SvPV(*name_svp, name_len);
SV **existing = hv_fetch(g_watchers, name, name_len, 0);
AV *callbacks;
if (existing && SvROK(*existing)) {
callbacks = (AV*)SvRV(*existing);
} else {
callbacks = newAV();
hv_store(g_watchers, name, name_len, newRV_noinc((SV*)callbacks), 0);
}
av_push(callbacks, SvREFCNT_inc(callback));
g_has_watchers[idx] = 1;
}
RETURN;
}
/* pp_slot_unwatch - unregister all watchers, idx in op_targ */
static OP* pp_slot_unwatch(pTHX) {
IV idx = PL_op->op_targ;
char key[32];
int klen = snprintf(key, sizeof(key), "%ld", (long)idx);
xs/slot/slot.c view on Meta::CPAN
char key[32];
int klen = snprintf(key, sizeof(key), "%ld", (long)idx);
SV **name_svp = hv_fetch(g_slot_names, key, klen, 0);
if (name_svp) {
STRLEN name_len;
const char *name = SvPV(*name_svp, name_len);
SV **existing = hv_fetch(g_watchers, name, name_len, 0);
if (existing && SvROK(*existing)) {
AV *callbacks = (AV*)SvRV(*existing);
SSize_t i, len = av_len(callbacks);
for (i = len; i >= 0; i--) {
SV **cb = av_fetch(callbacks, i, 0);
if (cb && SvRV(*cb) == SvRV(callback)) {
av_delete(callbacks, i, G_DISCARD);
}
}
if (av_len(callbacks) < 0) {
g_has_watchers[idx] = 0;
}
}
}
RETURN;
}
/* pp_slot_clear - reset slot to undef and clear watchers, idx in op_targ */
static OP* pp_slot_clear(pTHX) {
IV idx = PL_op->op_targ;
xs/slot/slot.c view on Meta::CPAN
int klen = snprintf(key, sizeof(key), "%ld", (long)idx);
SV **name_sv = hv_fetch(g_slot_names, key, klen, 0);
if (!name_sv || !SvOK(*name_sv)) return;
STRLEN name_len;
const char *name = SvPV(*name_sv, name_len);
SV **svp = hv_fetch(g_watchers, name, name_len, 0);
if (svp && SvROK(*svp) && SvTYPE(SvRV(*svp)) == SVt_PVAV) {
AV *callbacks = (AV*)SvRV(*svp);
SSize_t i, len = av_len(callbacks);
for (i = 0; i <= len; i++) {
SV **cb = av_fetch(callbacks, i, 0);
if (cb && SvROK(*cb)) {
dSP;
ENTER; SAVETMPS;
PUSHMARK(SP);
mXPUSHs(newSVpvn(name, name_len));
XPUSHs(new_val);
PUTBACK;
call_sv(*cb, G_DISCARD);
FREETMPS; LEAVE;
}
xs/slot/slot.c view on Meta::CPAN
============================================ */
static XS(xs_watch) {
dXSARGS;
if (items < 2) croak("Usage: slot::watch($name, $callback)");
char *name = SvPV_nolen(ST(0));
STRLEN name_len = SvCUR(ST(0));
SV *callback = ST(1);
SV **existing;
AV *callbacks;
SV **idx_sv;
existing = hv_fetch(g_watchers, name, name_len, 0);
if (existing && SvROK(*existing)) {
callbacks = (AV*)SvRV(*existing);
} else {
callbacks = newAV();
hv_store(g_watchers, name, name_len, newRV_noinc((SV*)callbacks), 0);
}
av_push(callbacks, SvREFCNT_inc(callback));
/* Set the has_watchers flag for fast path */
idx_sv = hv_fetch(g_slot_index, name, name_len, 0);
if (idx_sv) {
g_has_watchers[SvIV(*idx_sv)] = 1;
}
XSRETURN_EMPTY;
}
xs/slot/slot.c view on Meta::CPAN
SV **idx_sv;
int clear_flag = 0;
if (items == 1) {
hv_delete(g_watchers, name, name_len, G_DISCARD);
clear_flag = 1;
} else {
SV *callback = ST(1);
SV **existing = hv_fetch(g_watchers, name, name_len, 0);
if (existing && SvROK(*existing)) {
AV *callbacks = (AV*)SvRV(*existing);
SSize_t i, len = av_len(callbacks);
for (i = len; i >= 0; i--) {
SV **cb = av_fetch(callbacks, i, 0);
if (cb && SvRV(*cb) == SvRV(callback)) {
av_delete(callbacks, i, G_DISCARD);
}
}
/* Check if all watchers removed */
if (av_len(callbacks) < 0) {
clear_flag = 1;
}
}
}
/* Clear the has_watchers flag if no watchers left */
if (clear_flag) {
idx_sv = hv_fetch(g_slot_index, name, name_len, 0);
if (idx_sv) {
g_has_watchers[SvIV(*idx_sv)] = 0;
xs/util/Makefile.PL view on Meta::CPAN
use strict;
use warnings;
use ExtUtils::MakeMaker;
use Config;
# Platform-specific linker flags for symbol export
# Other XS modules can use util_callbacks.h to register C-level callbacks
my %platform_args;
if ($^O eq 'linux' || $^O eq 'freebsd' || $^O eq 'openbsd' || $^O eq 'netbsd' ||
$^O eq 'solaris' || $^O eq 'sunos' || $^O eq 'dragonfly') {
# Unix ELF systems: export symbols and set SONAME
$platform_args{LDDLFLAGS} = $Config{lddlflags} . ' -Wl,--export-dynamic -Wl,-soname,util.so';
}
elsif ($^O eq 'MSWin32' || $^O eq 'cygwin' || $^O eq 'msys') {
# Windows/Cygwin/MSYS: export all symbols for DLL linking
$platform_args{LDDLFLAGS} = ($Config{lddlflags} || '') . ' -Wl,--export-all-symbols';
}
xs/util/util.c view on Meta::CPAN
} PartialFunc;
static PartialFunc *g_partials = NULL;
static IV g_partial_size = 0;
static IV g_partial_count = 0;
/* ============================================
Loop callback registry structures
============================================ */
/* Function pointer types for loop callbacks */
typedef bool (*UtilPredicateFunc)(pTHX_ SV *elem);
typedef SV* (*UtilMapFunc)(pTHX_ SV *elem);
typedef SV* (*UtilReduceFunc)(pTHX_ SV *accum, SV *elem);
/* Registered callback entry */
typedef struct {
char *name; /* Callback name (e.g., ":is_positive") */
UtilPredicateFunc predicate; /* C function for predicates */
UtilMapFunc mapper; /* C function for map */
UtilReduceFunc reducer; /* C function for reduce */
xs/util/util.c view on Meta::CPAN
const char *pv = SvPV(args[i], len);
sv_catpvn(key, pv, len);
} else {
sv_catpvs(key, "\x01UNDEF\x01");
}
}
return key;
}
/* ============================================
Built-in predicates for loop callbacks
(prefixed with ':' for built-in names)
============================================ */
static bool builtin_is_defined(pTHX_ SV *elem) {
return SvOK(elem) ? TRUE : FALSE;
}
static bool builtin_is_true(pTHX_ SV *elem) {
return SvTRUE(elem) ? TRUE : FALSE;
}
xs/util/util.c view on Meta::CPAN
sv = newSViv(PTR2IV(cb));
hv_store(g_callback_registry, name, strlen(name), sv, 0);
}
/* Check if a callback exists */
static bool has_callback(pTHX_ const char *name) {
return get_registered_callback(aTHX_ name) != NULL;
}
/* List all registered callbacks */
static AV* list_callbacks(pTHX) {
AV *result;
HE *entry;
result = newAV();
if (!g_callback_registry) return result;
hv_iterinit(g_callback_registry);
while ((entry = hv_iternext(g_callback_registry))) {
I32 klen;
char *key = hv_iterkey(entry, &klen);
av_push(result, newSVpvn(key, klen));
}
return result;
}
/* Initialize built-in callbacks (called from BOOT) */
static void init_builtin_callbacks(pTHX) {
register_builtin_predicate(aTHX_ ":is_defined", builtin_is_defined);
register_builtin_predicate(aTHX_ ":is_true", builtin_is_true);
register_builtin_predicate(aTHX_ ":is_false", builtin_is_false);
register_builtin_predicate(aTHX_ ":is_ref", builtin_is_ref);
register_builtin_predicate(aTHX_ ":is_array", builtin_is_array);
register_builtin_predicate(aTHX_ ":is_hash", builtin_is_hash);
register_builtin_predicate(aTHX_ ":is_code", builtin_is_code);
register_builtin_predicate(aTHX_ ":is_positive", builtin_is_positive);
register_builtin_predicate(aTHX_ ":is_negative", builtin_is_negative);
register_builtin_predicate(aTHX_ ":is_zero", builtin_is_zero);
xs/util/util.c view on Meta::CPAN
STRLEN name_len;
const char *name = SvPV(ST(0), name_len);
if (has_callback(aTHX_ name)) {
XSRETURN_YES;
}
XSRETURN_NO;
}
/* List all callbacks */
static XS(xs_list_callbacks) {
dXSARGS;
PERL_UNUSED_ARG(items);
AV *result = list_callbacks(aTHX);
ST(0) = sv_2mortal(newRV_noinc((SV*)result));
XSRETURN(1);
}
/* ============================================
Import function - O(1) hash-based lookup
============================================ */
/* Export entry: supports XS functions, Perl coderefs, or both */
typedef struct {
xs/util/util.c view on Meta::CPAN
register_export(aTHX_ "any_cb", xs_any_cb, NULL);
register_export(aTHX_ "all_cb", xs_all_cb, NULL);
register_export(aTHX_ "none_cb", xs_none_cb, NULL);
register_export(aTHX_ "first_cb", xs_first_cb, NULL);
register_export(aTHX_ "grep_cb", xs_grep_cb, NULL);
register_export(aTHX_ "count_cb", xs_count_cb, NULL);
register_export(aTHX_ "partition_cb", xs_partition_cb, NULL);
register_export(aTHX_ "final_cb", xs_final_cb, NULL);
register_export(aTHX_ "register_callback", xs_register_callback, NULL);
register_export(aTHX_ "has_callback", xs_has_callback, NULL);
register_export(aTHX_ "list_callbacks", xs_list_callbacks, NULL);
/* Specialized predicates - first_* */
register_export(aTHX_ "first_gt", xs_first_gt, NULL);
register_export(aTHX_ "first_lt", xs_first_lt, NULL);
register_export(aTHX_ "first_ge", xs_first_ge, NULL);
register_export(aTHX_ "first_le", xs_first_le, NULL);
register_export(aTHX_ "first_eq", xs_first_eq, NULL);
register_export(aTHX_ "first_ne", xs_first_ne, NULL);
/* Specialized predicates - final_* */
xs/util/util.c view on Meta::CPAN
}
/* ============================================
Boot
============================================ */
XS_EXTERNAL(boot_util) {
dXSBOOTARGSXSAPIVERCHK;
PERL_UNUSED_VAR(items);
/* Initialize built-in loop callbacks */
init_builtin_callbacks(aTHX);
/* Register custom ops */
XopENTRY_set(&identity_xop, xop_name, "identity");
XopENTRY_set(&identity_xop, xop_desc, "identity passthrough");
Perl_custom_op_register(aTHX_ pp_identity, &identity_xop);
XopENTRY_set(&always_xop, xop_name, "always");
XopENTRY_set(&always_xop, xop_desc, "always return stored value");
Perl_custom_op_register(aTHX_ pp_always, &always_xop);
xs/util/util.c view on Meta::CPAN
newXS("util::any_cb", xs_any_cb, __FILE__);
newXS("util::all_cb", xs_all_cb, __FILE__);
newXS("util::none_cb", xs_none_cb, __FILE__);
newXS("util::first_cb", xs_first_cb, __FILE__);
newXS("util::grep_cb", xs_grep_cb, __FILE__);
newXS("util::count_cb", xs_count_cb, __FILE__);
newXS("util::partition_cb", xs_partition_cb, __FILE__);
newXS("util::final_cb", xs_final_cb, __FILE__);
newXS("util::register_callback", xs_register_callback, __FILE__);
newXS("util::has_callback", xs_has_callback, __FILE__);
newXS("util::list_callbacks", xs_list_callbacks, __FILE__);
/* Specialized array predicates - pure C, no callback */
newXS("util::first_gt", xs_first_gt, __FILE__);
newXS("util::first_lt", xs_first_lt, __FILE__);
newXS("util::first_ge", xs_first_ge, __FILE__);
newXS("util::first_le", xs_first_le, __FILE__);
newXS("util::first_eq", xs_first_eq, __FILE__);
newXS("util::first_ne", xs_first_ne, __FILE__);
newXS("util::final", xs_final, __FILE__);
newXS("util::final_gt", xs_final_gt, __FILE__);
xs/util/util_callbacks.h view on Meta::CPAN
/*
* util_callbacks.h - Public API for XS modules to register loop callbacks
*
* Include this header in your XS module to register C-level predicates,
* mappers, or reducers that util's loop functions can call directly
* without Perl callback overhead.
*
* Example usage in your XS BOOT section:
*
* #include "util_callbacks.h"
*
* static bool my_is_valid(pTHX_ SV *elem) {
* // your validation logic
* return SvOK(elem) && SvIV(elem) > 0;
* }
*
* BOOT:
* util_register_predicate_xs(aTHX_ "MyModule::is_valid", my_is_valid);
*
* Then in Perl:
xs/util/util_callbacks.h view on Meta::CPAN
* Register a C reducer function for reduce/fold operations.
*/
PERL_CALLCONV void util_register_reducer_xs(pTHX_ const char *name,
UtilReduceFunc func);
/* ============================================
Available loop functions
============================================ */
/*
* The following loop functions support named callbacks:
*
* any_cb(\@list, $name) - true if any element matches
* all_cb(\@list, $name) - true if all elements match
* none_cb(\@list, $name) - true if no element matches
* first_cb(\@list, $name) - first matching element
* final_cb(\@list, $name) - last matching element
* grep_cb(\@list, $name) - all matching elements
* count_cb(\@list, $name) - count of matching elements
* partition_cb(\@list, $name) - split into [matches], [non-matches]
*/
xs/util/util_callbacks.h view on Meta::CPAN
/*
* Callback overhead comparison:
*
* Built-in C predicate (:is_positive) ~5-10 cycles per element
* Registered C predicate ~5-10 cycles per element
* Perl callback via register_callback ~100+ cycles per element
* Block callback via any { ... } ~20-30 cycles (MULTICALL)
* ~100+ cycles (call_sv fallback)
*
* For hot loops processing millions of elements, C predicates provide
* 10-20x speedup over Perl callbacks.
*/
/* ============================================
Built-in predicates reference
============================================ */
/*
* The following built-in predicates are available:
*
* Type checks:
( run in 1.257 second using v1.01-cache-2.11-cpan-cdf2f3d4e48 )