XS-Framework

 view release on metacpan or  search on metacpan

lib/XS/Framework/Manual/SVAPI/Stash.pod  view on Meta::CPAN

This method creates new C<Object>, which is blessed into to the current package
(C<Stash>).

    Object bless (const Sv& what) const;

This C<bless> method version works somewhat similiar to the following Perl
construction

    my $class = ...;
    my $obj = ...;
    return bless $obj => $class;

i.e. if C<what> is already an object, it is blessed into the C<Stash>,
otherwise new C<RV*> created from the C<what> argument, and the
blessed object returned.

=head2 add_const_sub()

    void add_const_sub (const panda::string_view& name, const Sv& val);
    
Creates subroutine C<name> that returns constant C<val> eligible for compile-time inlining (like newCONSTSUB). C<val> is retained and made readonly.

lib/XS/Framework/Manual/Typemap.pod  view on Meta::CPAN

In that case SV* pointing to C<undef> is created, and it is blessed into the specified
package name. This is needed to follow standart Perl inheritance model, i.e. respect
when the current class might be derived in Perl or xs-adapter. In other words it
works similar to:

    package My::XXX;

    sub new {
        my $class = shift;
        my $obj = {};
        return bless $obj => $class;
    }

    package My::YYY;
    use base qw/My::XXX;

    my $obj_a = My::XXX->new;
    my $obj_b = My::YYY->new;

=item it might be already blessed Perl object

lib/XS/Framework/Manual/recipe07.pod  view on Meta::CPAN

=cut

=head1 C3 mixin introduction

Let's assume there is a Server with core functions defined in basic class.

    package MyBase {
        sub new {
            my $class = shift;
            return bless {} => $class;
        };
        sub on_client {
            my ($self, $client) = @_;
            print "MyBase::on_client\n";
            if ($client->{status} eq 'authorized'){ $client->{send} = '[welcome]' }
            elsif ($client->{status} eq 'not_authorized') { $client->{send} = '[disconnect]' };
        }
    }

The package is responsible for constructing object and send to client either
C<[welcome]> string upon successful login and C<[disconnect]> upon login falure.
It is desirable to have dedicated logging and authorizing components.

    package MyLogger {
        use base qw/MyBase/;    # (1)

        sub new {
            my $class = shift;
            my $obj = $class->next::method(@_) // {};   # (2)
            return bless $obj => $class;
        }
        sub on_client {
            my ($self, $client) = @_;
            print "MyLogger::on_client\n";  # (3)
            print "client ", $client->{id}, ", status = ", $client->{status}, "\n";
            $self->next::method($client);   # (4)
            print "client ", $client->{id}, ", status = ", $client->{status}, "\n";
        }
    }

    package MyAuth {
        use base qw/MyBase/;    # (5)

        sub new {
            my $class = shift;
            my $obj = $class->next::method(@_) // {};   # (6)
            return bless $obj => $class;
        }
        sub on_client {
            my ($self, $client) = @_;
            print "MyAuth::on_client\n";    # (7)
            if ($client->{id} < 0) { $client->{status} = 'not_authorized'; }
            else { $client->{status} = 'authorized'; }
            $self->next::method($client);   # (8)
        }
    };

lib/XS/Framework/Manual/recipe07.pod  view on Meta::CPAN

The real magic happens in C<next::method> (4) and (8): the plugins forwards
call either to base class C<MyBase> or to next plugin. This is not known
at the place of invocation and it is defined at place, where plug-ins are
inherited, i.e. in the I<gather point>:

    package MyXServer {
        use base qw/MyLogger MyAuth MyBase/;    # (9)
        sub new {
            my $class = shift;
            my $obj = $class->next::method(@_) // {};
            return bless $obj => $class;
        }
    };

In (9) it is said that C<MyLogger> plugin's interceptors are executed first,
then C<MyAuth> interceptors are executed, and only then the generic (may be
empty) methods of C<MyBase> will be executed. C3/mro resolves multiple
inheritance problem, i.e. linearizes inheritance tree from most specific
(child) to the most generic (parent) classes.

The sample code

misc/leak1.plx  view on Meta::CPAN

use MyTest;
use Devel::Peek;
use BSD::Resource;

{
    package MyClass;

    sub new {
        my ($class, $value) = @_;
        my $obj = {_value => $value};
        return bless $obj => $class;
    }
}

while (1) {
    MyTest::test_leaks1("MyClass", "new", 10000);
    say BSD::Resource::getrusage()->{"maxrss"};
}

t/cookbook/recipe07.t  view on Meta::CPAN

use strict;
use warnings;
BEGIN { require "./t/cookbook/TestCookbook.pm"; }

package MyBase {
    sub new {
        my $class = shift;
        return bless {} => $class;
    };
    sub on_client {
        my ($self, $client) = @_;
        print "MyBase::on_client\n";
        if ($client->{status} eq 'authorized'){ $client->{send} = '[welcome]' }
        elsif ($client->{status} eq 'not_authorized') { $client->{send} = '[disconnect]' };
    }
};

package MyLogger {
    use base qw/MyBase/;

    sub new {
        my $class = shift;
        my $obj = $class->next::method(@_) // {};
        return bless $obj => $class;
    }
    sub on_client {
        my ($self, $client) = @_;
        print "MyLogger::on_client\n";
        print "client ", $client->{id}, ", status = ", $client->{status}, "\n";
        $self->next::method($client);
        print "client ", $client->{id}, ", status = ", $client->{status}, "\n";
    }
};

package MyAuth {
    use base qw/MyBase/;

    sub new {
        my $class = shift;
        my $obj = $class->next::method(@_) // {};
        return bless $obj => $class;
    }
    sub on_client {
        my ($self, $client) = @_;
        print "MyAuth::on_client\n";
        if ($client->{id} < 0) { $client->{status} = 'not_authorized'; }
        else { $client->{status} = 'authorized'; }
        $self->next::method($client);
    }
};

package MyXServer {
    use base qw/MyLogger MyAuth MyBase/;
    sub new {
        my $class = shift;
        my $obj = $class->next::method(@_) // {};
        return bless $obj => $class;
    }
};

my $client = {status => 'connected', id => 10};
my $server = MyXServer->new;
$server->on_client($client);

print "\nLet's try in XS\n";

my $client2 = MyTest::Cookbook::Client07->new(10);