view release on metacpan or  search on metacpan

lib/MM/Table.pm  view on Meta::CPAN

    for( my $i = 0; $i < scalar( @$src ); $i++ )
    {
        my $e = $src->[ $i ];
        next if( $e->{lkey} ne $lkey );
        return( $e->{val} );
    }

    return;
}

sub merge
{
    my( $self, $key, $val ) = @_;

    $self->_validate_key( $key ) || return( $self->pass_error );
    $val = $self->_stringify_value( $val );
    my $lkey = lc( $key );

    my $st  = $self->_state();
    my $src = $st->{_entries} || [];

    for( my $i = 0; $i < scalar( @$src ); $i++ )
    {
        my $e = $src->[ $i ];
        next if( $e->{lkey} ne $lkey );

        $e->{val} = $e->{val} . ', ' . $val;
        $self->_invalidate_tie_cache();
        return( $self );
    }

    push( @$src, { key => $key, lkey => $lkey, val => $val } );
    $self->_invalidate_tie_cache();
    return( $self );
}

sub overlap
{
    my( $self, $other, $flags ) = @_;

    $self->_validate_table( $other )         || return( $self->pass_error );
    $self->_validate_overlap_flags( $flags ) || return( $self->pass_error );
    $flags //= 0;

    my $o = $other->_state()->{_entries} || [];
    for( my $i = 0; $i < scalar( @$o ); $i++ )
    {
        my $e = $o->[ $i ];
        if( $flags )
        {
            $self->merge( $e->{key}, $e->{val} ) || return( $self->pass_error );
        }
        else
        {
            $self->set( $e->{key}, $e->{val} ) || return( $self->pass_error );
        }
    }
    return( $self );
}

sub overlay
{
    my( $self, $other ) = @_;

    $self->_validate_table( $other ) || return( $self->pass_error );

    my $class = ref( $self ) || $self;

    my $state =
    {
        _entries   => [],
        _error     => undef,
        _tied_href => undef,
    };

    my $new = bless( \$state, $class );

    my $dst = $new->_state()->{_entries};

    my $o = $other->_state()->{_entries} || [];
    for( my $i = 0; $i < scalar( @$o ); $i++ )
    {
        my $e = $o->[ $i ];
        push( @$dst, { key => $e->{key}, lkey => $e->{lkey}, val => $e->{val} } );
    }

    my $s = $self->_state()->{_entries} || [];
    for( my $i = 0; $i < scalar( @$s ); $i++ )
    {
        my $e = $s->[$i];
        push( @$dst, { key => $e->{key}, lkey => $e->{lkey}, val => $e->{val} } );
    }

    return( $new );
}

# pass_error()
# Propagates the error stored in this instance: sets it as the current
# error and returns undef (or empty list), exactly as error() does, but
# without creating a new exception object.
sub pass_error
{
    my $self = shift( @_ );
    # If called with arguments, delegate to error() to create a new exception.
    return( $self->error( @_ ) ) if( @_ );
    # No arguments: the error is already stored in the instance by the method
    # that failed. We simply return, letting Perl resolve the context: undef
    # in scalar context, empty list in list context.
    return;
}

sub set
{
    my( $self, $key, $val ) = @_;

    $self->_validate_key( $key ) || return( $self->pass_error );
    $val = $self->_stringify_value( $val );
    my $lkey = lc( $key );

    my $st  = $self->_state();
    my $src = $st->{_entries} || [];

lib/MM/Table.pm  view on Meta::CPAN

    my( $self ) = @_;
    $self->{_iter} = 0;
    $self->{_curr} = undef;
    return( $self->NEXTKEY( undef ) );
}

sub NEXTKEY
{
    my( $self, $lastkey ) = @_;

    my $src = $self->{_table}->_state()->{_entries} || [];

    if( $self->{_iter} >= scalar( @$src ) )
    {
        $self->{_curr} = undef;
        return( undef );
    }

    my $idx = $self->{_iter};
    $self->{_iter}++;
    $self->{_curr} = $idx;

    return( $src->[$idx]->{key} );
}

sub STORE
{
    my( $self, $key, $val ) = @_;
    return unless( defined( $key ) && !ref( $key ) );
    $self->{_table}->set( $key, $val );
    return;
}

1;
# NOTE: POD
__END__

=encoding utf8

=head1 NAME

MM::Table - Pure-Perl mimic of APR::Table (multi-valued, case-insensitive table)

=head1 SYNOPSIS

    use MM::Table ();
    use MM::Const qw( :table );

    my $t = MM::Table->make;

    $t->set( Foo => "one" ) || die( $t->error );
    $t->add( foo => "two" ) || die( $t->error );

    my $v  = $t->get( 'FOO' );     # "one" (scalar ctx: oldest)
    my @vs = $t->get( 'foo' );     # ("one","two")

    $t->merge( foo => "three" );   # first "foo" becomes "one, three"

    my $copy = $t->copy;

    my $o = $t->overlay( $copy );

    $t->compress( OVERLAP_TABLES_SET );    # flattens to last value per key
    $t->compress( OVERLAP_TABLES_MERGE );  # flattens to "a, b, c"

    $t->do( sub{ print "$_[0] => $_[1]\n"; 1 } ) || die( $t->error );

    # APR-like deref:
    $t->{foo} = "bar";      # calls set()
    print $t->{foo};        # calls get()
    print "yes\n" if( exists( $t->{foo} ) );

    while( my( $k, $v ) = each( %$t ) )
    {
        print "$k => $v\n";    # duplicates preserved in insertion order
    }

=head1 VERSION

    v0.5.0

=head1 DESCRIPTION

A pure-Perl, ordered, multi-valued, case-insensitive key-value table, modelled on L<APR::Table>. Used internally by L<Mail::Make::Headers> to store mail header fields in insertion order while allowing case-insensitive lookup and multiple values per f...

=head1 ERROR HANDLING

C<MM::Table> does not inherit from L<Module::Generic>, but follows the same error convention used throughout the C<Mail::Make> ecosystem:

=over 4

=item * On error, a method stores a L<Mail::Make::Exception> object via L</error> and returns C<undef> in scalar context or an empty list in list context.

=item * The caller retrieves the exception with C<< $t->error >>.

=item * L</pass_error> is provided for propagating an error set earlier in the same object.

=back

Because C<MM::Table> is never instantiated by untrusted input and construction cannot fail, there is no class-level C<< MM::Table->error >> - errors are always per-instance.

=head1 CONSTRUCTOR

=head2 make

    my $t = MM::Table->make;

Creates and returns a new, empty C<MM::Table> instance.

=head1 METHODS

=head2 add( $key, $value )

Appends a new entry without removing any existing entries for C<$key>.
Returns C<$self>, or C<undef> on error.

=head2 clear

Removes all entries. Returns C<$self>.

=head2 compress( $flags )

Flattens duplicate keys. C<$flags> must be C<OVERLAP_TABLES_SET> (C<0>) to keep only the last value, or C<OVERLAP_TABLES_MERGE> (C<1>) to join all values with C<", ">. Returns C<$self>, or C<undef> on error.

=head2 copy

Returns a deep copy of the table as a new C<MM::Table> instance.

=head2 do( $callback [, @filter_keys] )

Iterates over all entries in insertion order, calling C<< $callback->( $key, $value ) >> for each. Iteration stops if the callback returns a false value.
If C<@filter_keys> is provided, only entries whose lowercased key matches one of the filter keys are visited. Returns C<$self>, or C<undef> on error.

=head2 error( [$message] )

Without argument: returns the stored L<Mail::Make::Exception> object, or C<undef> if no error has occurred.

With one or more arguments: joins them into a message, creates a L<Mail::Make::Exception>, stores it, and returns C<undef>.

=head2 get( $key )

In scalar context: returns the value of the first matching entry, or C<undef>. In list context: returns all values for C<$key>, in insertion order. Returns C<undef>/empty list on error.

=head2 merge( $key, $value )

If an entry for C<$key> already exists, appends C<", $value"> to its value.
Otherwise behaves like L</add>. Returns C<$self>, or C<undef> on error.

=head2 overlap( $other_table, $flags )

Copies all entries from C<$other_table> into C<$self>. With C<OVERLAP_TABLES_SET> each key is replaced; with C<OVERLAP_TABLES_MERGE> values are appended. Returns C<$self>, or C<undef> on error.

=head2 overlay( $other_table )

Returns a new C<MM::Table> containing all entries from C<$other_table> followed by all entries from C<$self> (C<$other_table> entries come first).
Returns the new table, or C<undef> on error.

=head2 pass_error

Propagates the error currently stored in this instance by returning C<undef>. If called with arguments, delegates to L</error> to create a new exception first.

=head2 set( $key, $value )

Removes all existing entries for C<$key> and adds a single new one.
Returns C<$self>, or C<undef> on error.

=head2 unset( $key )

Removes all entries for C<$key>. Returns C<$self>, or C<undef> on error.

=head1 TIED-HASH INTERFACE

C<MM::Table> overloads C<%{}> to expose a tied hash interface compatible with APR::Table's C<< $t->{key} >> syntax. Assignment calls L</set>, deletion calls L</unset>, and C<each>/C<keys>/C<values> iterate in insertion order. Multiple values for the ...

=head1 NOTES / LIMITATIONS

=over 4

=item * Performance

All lookups are linear scans. C<MM::Table> is designed for the small, bounded sets of headers found in email messages, not for large tables.

=item * C<copy> and the C<$pool> argument

The C<copy> method accepts no arguments. The C<$pool> parameter present in the original C<APR::Table> API has no equivalent here.

=back

=head1 AUTHOR

Jacques Deguest E<lt>F<jack@deguest.jp>E<gt>

=head1 SEE ALSO

L<APR::Table>, L<Mail::Make::Headers>, L<Mail::Make::Exception>

=head1 COPYRIGHT & LICENSE

Copyright(c) 2026 DEGUEST Pte. Ltd.

All rights reserved.

This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.

=cut