updated results from the CPAN

Ancient

    my $new = $list->insert_at_pos($pos, $data);

Inserts a new node at the specified position.
Returns a new list object pointing to the inserted node.

=head2 remove

    my $data = $list->remove;

Removes the current node and returns its data.
The list object is updated to point to the next (or previous) node.

=head2 remove_from_start

    my $data = $list->remove_from_start;

Removes the head node and returns its data.

=head2 remove_from_end

    my $data = $list->remove_from_end;

lib/object.pm view on Meta::CPAN


Wrap existing methods with before, after, or around hooks. Zero overhead
for classes that don't use modifiers.

=head2 object::before($method, $callback)

Run code before a method. Arguments are passed to the callback.

    object::before('Person::save', sub {
        my ($self) = @_;
        $self->updated_at(time);
    });

=head2 object::after($method, $callback)

Run code after a method. Arguments are passed to the callback.

    object::after('Person::save', sub {
        my ($self) = @_;
        log_action("Saved person: " . $self->name);
    });

t/0014-all-slot-ops.t view on Meta::CPAN

use slot qw(opt_test);

# Initialize
opt_test(100);

# Test slot::get optimization
is(slot::get('opt_test'), 100, 'slot::get(const) works');

# Test slot::set optimization
is(slot::set('opt_test', 200), 200, 'slot::set(const,$v) works');
is(opt_test(), 200, 'slot::set updated value');

# Test slot::index optimization (constant folded)
my $idx = slot::index('opt_test');
is($idx, 0, 'slot::index(const) returns correct index');

# Test slot::watch optimization
my @events;
slot::watch('opt_test', sub {
    my ($name, $val) = @_;
    push @events, [$name, $val];

t/0015-slot-map-grep.t view on Meta::CPAN

# ============================================
# Slot setters in for loop
# ============================================
subtest 'slot setters in for loop' => sub {
    my @new_values = (10, 20, 30);
    
    test_slot1($new_values[0]);
    test_slot2($new_values[1]);
    test_slot3($new_values[2]);
    
    is(test_slot1(), 10, 'slot1 updated');
    is(test_slot2(), 20, 'slot2 updated');
    is(test_slot3(), 30, 'slot3 updated');
};

# ============================================
# Slots with map transformation
# ============================================
subtest 'slots with map transformation' => sub {
    test_slot1(5);
    test_slot2(10);
    test_slot3(15);

t/2026-doubly-cross-threads.t view on Meta::CPAN

    $list->add(42);
    my $val = $list->data;  # Get the value before thread
    
    my $t = threads->create(sub {
        # Can't access $list, but can access shared $result
        $result = $val * 2;  # Use value captured before thread
        return 1;
    });
    $t->join;

    is($result, 84, 'shared variable updated by thread');
    is($list->data, 42, 'original list unchanged');
};

done_testing();

t/4009-object-accessor-behavior.t view on Meta::CPAN


# ==== Accessor Return Values ====

subtest 'getter returns current value' => sub {
    object::define('GetterTest', 'val:Str');

    my $obj = new GetterTest val => 'initial';
    is($obj->val, 'initial', 'getter returns value');

    # Chained assignment
    my $ret = $obj->val('updated');
    is($ret, 'updated', 'setter returns new value');
    is($obj->val, 'updated', 'value was actually set');
};

subtest 'method chaining' => sub {
    object::define('ChainTest', 'a:Str', 'b:Int', 'c:Num');

    my $obj = new ChainTest a => '', b => 0, c => 0.0;

    # Value is returned, allowing use in expressions
    my $res = $obj->a('hello');
    is($res, 'hello', 'setter returns value for chaining');

t/4018-object-multi-import.t view on Meta::CPAN

# ============================================

subtest 'setters work across multiple objects' => sub {
    my $person = new Person 'Charlie', 25, 'charlie@test.com';
    my $address = new Address '456 Oak Ave', 'Shelbyville', '67890', 'USA';

    # Update using function-style setters
    name($person, 'Charles');
    age($person, 26);

    is(name($person), 'Charles', 'Person name updated');
    is(age($person), 26, 'Person age updated');

    city($address, 'Capital City');
    zipcode($address, '99999');

    is(city($address), 'Capital City', 'Address city updated');
    is(zipcode($address), '99999', 'Address zipcode updated');
};

subtest 'aliased setters work correctly' => sub {
    my $product = new Product 'SKU002', 'Gadget', 19.99, 50;

    product_name($product, 'Super Gadget');
    price($product, 24.99);
    qty($product, 75);

    is(product_name($product), 'Super Gadget', 'Product name updated via alias');
    is(price($product), 24.99, 'Product price updated');
    is(qty($product), 75, 'Product quantity updated via alias');

    # Verify method accessors also see the updates
    is($product->name, 'Super Gadget', 'Method accessor sees alias update');
    is($product->quantity, 75, 'Method accessor sees alias update');
};

# ============================================
# Multiple objects in loops
# ============================================

t/4018-object-multi-import.t view on Meta::CPAN

    }

    # Create order
    my $order = new Order 'ORD-001', name($customer), $total, 'processing';

    is(order_total($order), 60.00, 'Order total calculated correctly');
    is(customer($order), 'Dave', 'Order customer matches person name');

    # Update order status
    order_status($order, 'shipped');
    is(order_status($order), 'shipped', 'Order status updated');
};

subtest 'config management with function accessors' => sub {
    my $dev_config = new Config 'localhost', 3000, 30, 1;
    my $prod_config = new Config 'api.example.com', 443, 60, 0;

    is(host($dev_config), 'localhost', 'dev host');
    is(port($dev_config), 3000, 'dev port');
    is(debug($dev_config), 1, 'dev debug enabled');

    is(host($prod_config), 'api.example.com', 'prod host');
    is(port($prod_config), 443, 'prod port');
    is(debug($prod_config), 0, 'prod debug disabled');

    # Update timeout across configs
    timeout($dev_config, 120);
    timeout($prod_config, 90);

    is(timeout($dev_config), 120, 'dev timeout updated');
    is(timeout($prod_config), 90, 'prod timeout updated');
};

# ============================================
# Simultaneous access to same-named properties
# ============================================

subtest 'same property name different objects' => sub {
    # Both Person and Product have 'name', but Product is aliased
    my $person = new Person 'Eve', 28, 'eve@test.com';
    my $product = new Product 'SKU-X', 'Thingamajig', 15.00, 10;

t/4018-object-multi-import.t view on Meta::CPAN

        test => new Config('test.example.com', 8080, 45, 1),
        prod => new Config('api.example.com', 443, 60, 0),
    );

    is(host($configs{dev}), 'localhost', 'hash access dev host');
    is(port($configs{test}), 8080, 'hash access test port');
    is(timeout($configs{prod}), 60, 'hash access prod timeout');

    # Update via hash access
    debug($configs{prod}, 1);  # Enable debug in prod (oops!)
    is(debug($configs{prod}), 1, 'updated via hash access');
};

# ============================================
# Object transformation pipelines
# ============================================

subtest 'transform objects in pipeline' => sub {
    my @people = (
        new Person('alice', 30, 'alice@test.com'),
        new Person('bob', 25, 'bob@test.com'),

t/4024-object-roles.t view on Meta::CPAN


# Test 5: Role without required method fails
object::define('BadDoc', 'title:Str');
eval { object::with('BadDoc', 'Printable') };
ok($@, 'Class without required method fails');
like($@, qr/does not implement required method 'to_string'/, 'Error mentions missing method');

# Test 6: Multiple roles
object::role('Timestamped',
    'created_at:Str',
    'updated_at:Str',
);

object::define('Article',
    'title:Str:required',
);
object::with('Article', 'Serializable', 'Timestamped');

my $article = Article->new(title => "News");
ok($article->can('format'), 'Article has Serializable slot');
ok($article->can('created_at'), 'Article has Timestamped slot');

t/5002-lru-keys.t view on Meta::CPAN

$cache->set('a', 1);
$cache->set('b', 2);
$cache->set('c', 3);

my @keys = $cache->keys;
is_deeply(\@keys, ['c', 'b', 'a'], 'keys in LRU order (most recent first)');

# Access 'a' to promote it
$cache->get('a');
@keys = $cache->keys;
is_deeply(\@keys, ['a', 'c', 'b'], 'keys updated after get');

# Test update existing key
$cache->set('b', 20);
is($cache->get('b'), 20, 'value updated');
@keys = $cache->keys;
is($keys[0], 'b', 'updated key moved to front');

# Test complex values
my $c2 = lru::new(10);
$c2->set('hash', { name => 'Bob', age => 30 });
$c2->set('array', [1, 2, 3]);
$c2->set('ref', \42);

my $h = $c2->get('hash');
is_deeply($h, { name => 'Bob', age => 30 }, 'hash value preserved');

t/5010-lru-oldest-newest.t view on Meta::CPAN

    is($ok, 'b', 'oldest is now b');
};

subtest 'set updates newest' => sub {
    my $c = lru::new(5);
    $c->set('a', 1);
    $c->set('b', 2);
    $c->set('a', 10);  # Update 'a', should move to front
    
    my ($nk, $nv) = $c->newest;
    is($nk, 'a', 'updated entry becomes newest');
    is($nv, 10, 'newest has updated value');
};

subtest 'eviction updates oldest' => sub {
    my $c = lru::new(3);
    $c->set('a', 1);
    $c->set('b', 2);
    $c->set('c', 3);
    $c->set('d', 4);  # Evicts 'a'
    
    my ($ok, $ov) = $c->oldest;

t/5010-lru-oldest-newest.t view on Meta::CPAN

};

subtest 'delete affects oldest/newest' => sub {
    my $c = lru::new(5);
    $c->set('a', 1);
    $c->set('b', 2);
    $c->set('c', 3);
    
    $c->delete('c');  # Delete newest
    my ($nk, $nv) = $c->newest;
    is($nk, 'b', 'newest updated after delete');
    
    $c->delete('a');  # Delete oldest
    my ($ok, $ov) = $c->oldest;
    is($ok, 'b', 'oldest updated after delete');
};

subtest 'clear empties oldest/newest' => sub {
    my $c = lru::new(5);
    $c->set('a', 1);
    $c->set('b', 2);
    $c->clear;
    
    my @oldest = $c->oldest;
    my @newest = $c->newest;

t/8000-file-basic.t view on Meta::CPAN

    # Touch new file
    ok(file::touch($file), 'touch new file returns true');
    ok(file::exists($file), 'touched file exists');
    is(file::size($file), 0, 'touched file is empty');

    # Touch existing file - should update mtime
    my $mtime1 = file::mtime($file);
    sleep(1);  # Need a small delay
    ok(file::touch($file), 'touch existing file returns true');
    my $mtime2 = file::mtime($file);
    ok($mtime2 >= $mtime1, 'mtime updated after touch');
};

# Test chmod
subtest 'chmod' => sub {
    my $file = "$tmpdir/chmod_test.txt";
    file::spew($file, "chmod test");

    ok(file::chmod($file, 0644), 'chmod returns true');
    # Mode check is platform-specific, just verify no error
};

t/9005-leak-doubly-leak.t view on Meta::CPAN

    $node = $node->next;
    $node = $node->end;
    $node = $node->prev;
    $node = $node->start;
}, 20_000);

# Test 6: data() get/set
test_no_leak('doubly data get/set', sub {
    my $list = doubly->new("original");
    my $data = $list->data;
    $list->data("updated");
    $data = $list->data;
}, 50_000);

# Test 7: remove operations
test_no_leak('doubly remove', sub {
    my $list = doubly->new(1);
    $list->add(2)->add(3)->add(4)->add(5);
    $list->remove_from_start;
    $list->remove_from_end;
    my $node = $list->start;

t/9012-cross-slot-util.t view on Meta::CPAN

# Initialize slots
counter(0);
items([]);

# Test slot values with predicates
ok(is_num(counter()) ? 1 : 0, 'slot counter is number');
ok(is_array(items()) ? 1 : 0, 'slot items is array');

# Update and verify
counter(42);
is(counter(), 42, 'counter updated');
ok(is_num(counter()) ? 1 : 0, 'still a number after update');

# Test memoized function that uses slots
my $call_count = 0;
my $get_double = memo(sub {
    my $n = shift;
    $call_count++;
    return $n * 2;
});

t/9032-leak-lru.t view on Meta::CPAN

            my $v = $cache->get("key25");
        }
    } 'lru get no leak';
};

subtest 'lru set existing key no leak' => sub {
    my $cache = lru::new(100);
    $cache->set("key", "initial");
    no_leaks_ok {
        for (1..1000) {
            $cache->set("key", "updated");
        }
    } 'lru set existing no leak';
};

subtest 'lru exists no leak' => sub {
    my $cache = lru::new(100);
    $cache->set("key$_", "value$_") for 1..50;
    no_leaks_ok {
        for (1..1000) {
            my $e = $cache->exists("key25");

t/9042-leak-object-extended.t view on Meta::CPAN

            my $a = $keys_obj->a;
            my $b = $keys_obj->b;
            my $c = $keys_obj->c;
        }
    } 'accessor get repeated does not leak';
};

subtest 'accessor set repeated no leak' => sub {
    no_leaks_ok {
        for (1..500) {
            $keys_obj->a('updated');
            $keys_obj->b(99);
            $keys_obj->c(2.71);
        }
    } 'accessor set repeated does not leak';
};

# ============================================
# Lock operations
# ============================================

t/9047-leak-doubly-leaktrace.t view on Meta::CPAN

        for (1..500) {
            my $d = $list->data;
        }
    } 'data get does not leak';
};

subtest 'data set no leak' => sub {
    my $list = doubly->new("initial");
    no_leaks_ok {
        for (1..500) {
            $list->data("updated_$_");
        }
    } 'data set does not leak';
};

# ============================================
# Predicates
# ============================================

subtest 'is_start/is_end no leak' => sub {
    my $list = doubly->new(1);

t/9057-leak-object-singleton.t view on Meta::CPAN

            my $cfg = $s->config;
            my $cnt = $s->count;
        }
    } 'singleton accessor get no leak';
};

subtest 'singleton accessor set no leak' => sub {
    my $s = LeakSingleton1->instance();
    no_leaks_ok {
        for (1..1000) {
            $s->config('updated');
            $s->count(42);
        }
    } 'singleton accessor set no leak';
};

subtest 'singleton state increment no leak' => sub {
    my $s = LeakSingleton1->instance();
    $s->count(0);
    no_leaks_ok {
        for (1..1000) {

( run in 1.524 second using v1.01-cache-2.11-cpan-df04353d9ac )