weaken results from the CPAN

weaken

DJabberd

view release on metacpan or search on metacpan

#
# usage:
#   xml-test.pl         (automatic mode)
#   xml-test.pl libxml
#   xml-test.pl expat

use strict;
use warnings;
use XML::SAX;
use XML::SAX::ParserFactory;
use Scalar::Util qw(weaken);
use Test::More tests => 11;
use Data::Dumper;

my $mode = shift;

my $factory = XML::SAX::ParserFactory->new;
my $wanted = ""; # set to nothing to let the factory choose a parser
my $iter_method;

if ($mode eq "") {

dev/xml-test.pl view on Meta::CPAN

{
    my $handler = EventRecorder->new(\$full_events);
    my $p       = $factory->parser(Handler => $handler);
    if ($wanted) {
        isa_ok($p, $wanted);
    } else {
        ok(1);
    }
    $p->parse_string($fulldoc);
    $weakcheck = \$p;
    weaken($weakcheck);
    $weakcheck_h = \$handler;
    weaken($weakcheck_h);

    like($full_events, qr/\{aa\}name/, "parser supports namespaces properly");
    like($full_events, qr/\{bb\}name/, "parser supports namespaces properly");
    like($full_events, qr/\{\}global/, "parser supports namespaces properly");
}
is($weakcheck, undef, "parser was destroyed");
is($weakcheck_h, undef, "handler was destroyed");

# now we do the way we want, sending chunks:
my $streamed_events;
{
    my $handler = EventRecorder->new(\$streamed_events);
    my $p       = $factory->parser(Handler => $handler);
    $p->$iter_method($first_chunk);
    $p->$iter_method($second_chunk);
    $weakcheck = \$p;
    weaken($weakcheck);

}
is($weakcheck, undef, "parser was destroyed");

use Text::Diff;
my $diff = diff(\$full_events, \$streamed_events);
#$diff = substr($diff, 0, 200);
is($diff, "", "events match either way");

# byte at a time

dev/xml-test.pl view on Meta::CPAN


package XML::LibXML::SAX::Better;
use strict;
use vars qw($VERSION @ISA);
$VERSION = '1.00';
use XML::LibXML;
use XML::SAX::Base;
use base qw(XML::SAX::Base);
use Carp;
use Data::Dumper;
use Scalar::Util qw(weaken);

sub new {
    my ($class, @params) = @_;
    my $inst = $class->SUPER::new(@params);

    my $libxml = XML::LibXML->new;
    $libxml->set_handler( $inst );
    $inst->{LibParser} = $libxml;

    # setup SAX.  1 means "with SAX"

lib/DJabberd.pm view on Meta::CPAN

    # if they set s2s_port to explicitly 0, it's disabled for all vhosts
    # but not setting it means 5269 still listens, if vhosts are configured
    # for s2s.
    # {=serverportnumber}
    $self->{s2s_port} = 5269 unless defined $self->{s2s_port};

    croak("Unknown server parameters: " . join(", ", keys %opts)) if %opts;

    bless $self, $class;
    $server{$self} = $self;
    Scalar::Util::weaken($server{$self});

    return $self;
}

sub DESTROY {
    delete $server{$_[0]};
}

# class method
sub foreach_vhost {

lib/DJabberd.pm view on Meta::CPAN


# return the version of the spec we implement
sub spec_version {
    my $self = shift;
    return $self->{_spec_version} ||= DJabberd::StreamVersion->new("1.0");
}


my %obj_source;   # refaddr -> file/linenumber
my %obj_living;   # file/linenumber -> ct
use Scalar::Util qw(refaddr weaken);
use Data::Dumper;
sub dump_obj_stats {
    print Dumper(\%obj_living);
    my %class_ct;
    foreach (values %obj_source) {
        $class_ct{ref($_->[1])}++;
    }
    print Dumper(\%class_ct);
}

lib/DJabberd.pm view on Meta::CPAN

    my $fileline;
    while (!$fileline) {
        $i++;
        my ($pkg, $filename, $line, $subname) = caller($i);
        next if $subname eq "new";
        $fileline = "$filename/$line";
    }
    my $addr = refaddr($obj);
    warn "New object $obj -- $fileline\n" if $ENV{TRACKOBJ};
    $obj_source{$addr} = [$fileline, $obj];
    weaken($obj_source{$addr}[1]);

    $obj_living{$fileline}++;
    dump_obj_stats() if $ENV{TRACKOBJ};
}

sub track_destroyed_obj {
    return unless $ENV{TRACKOBJ};

    my ($class, $obj) = @_;
    my $addr = refaddr($obj);

lib/DJabberd/Bot.pm view on Meta::CPAN

sub vhost {
    return $_[0]->{vhost};
}

sub register {
    my ($self, $vhost) = @_;
    my $barejid = DJabberd::JID->new("$self->{nodename}\@" . $vhost->server_name );
    my $resource = $self->{resource};

    $self->{vhost} = $vhost;
    Scalar::Util::weaken($self->{vhost});

    my $reg_jid;
    my $regcb = DJabberd::Callback->new({
        registered => sub {
            (undef, $reg_jid) = @_;
            $logger->debug("Bot $reg_jid is now registered");
        },
        error => sub {
            $logger->error("Bot $barejid/$resource failed to register");
            },

lib/DJabberd/Connection.pm view on Meta::CPAN


sub new {
    my ($class, $sock, $server) = @_;
    my $self = $class->SUPER::new($sock);

    croak("Server param not a DJabberd (server) object, '" . ref($server) . "'")
        unless $server->isa("DJabberd");

    $self->{vhost}   = undef;  # set once we get a stream start header from them.
    $self->{server}  = $server;
    Scalar::Util::weaken($self->{server});

    $self->{log}     = DJabberd::Log->get_logger($class);

    # hack to inject XML after Connection:: in the logger category
    my $xml_category = $class;
    $xml_category =~ s/Connection::/Connection::XML::/;

    $self->{xmllog}  = DJabberd::Log->get_logger($xml_category);

    my $fromip = $self->peer_ip_string || "<undef>";

lib/DJabberd/Connection.pm view on Meta::CPAN

}

# this can fail to signal that this connection can't work on this
# vhost for instance, this vhost doesn't support s2s, so a serverin or
# dialback subclass can override this to return 0 when s2s isn't
# enabled for the vhost
sub set_vhost {
    my ($self, $vhost) = @_;
    Carp::croak("Not a DJabberd::VHost: $vhost") unless UNIVERSAL::isa($vhost, "DJabberd::VHost");
    $self->{vhost} = $vhost;
    Scalar::Util::weaken($self->{vhost});
    return 1;
}

# called by DJabberd::SAXHandler
sub on_stanza_received {
    my ($self, $node) = @_;
    die "SUBCLASSES MUST OVERRIDE 'on_stanza_received' for $self\n";
}

# subclasses should override returning 0 or 1

lib/DJabberd/Connection/ComponentIn.pm view on Meta::CPAN


sub new {
    my ($class, $socket, $server, $handler) = @_;

    $logger->debug("Making a $class for fd ".fileno($socket));
    
    my $self = $class->SUPER::new($socket, $server);

    $self->{authenticated} = 0;
    $self->{cmpnt_handler} = $handler;
    Scalar::Util::weaken($self->{cmpnt_handler});
    
    return $self;
}

sub close {
    my $self = shift;
    return if $self->{closed};
    
    $self->{cmpnt_handler}->handle_component_disconnect($self);

lib/DJabberd/Connection/ComponentOut.pm view on Meta::CPAN

    
    my $self = $class->SUPER::new($sock, $server);
    $self->watch_write(1);

    $self->set_vhost($vhost);
    $self->{secret} = $secret;
    $self->{authenticated} = 0;
    $self->{state} = 'connecting';
    
    #$self->{cmpnt_handler} = $handler;
    #Scalar::Util::weaken($self->{cmpnt_handler});

    $logger->debug("$class initialized");
    
    return $self;
}

sub on_connected {
    my ($self) = @_;
    my $vhost = $self->{vhost};

lib/DJabberd/Connection/DialbackVerify.pm view on Meta::CPAN

    connect $sock, Socket::sockaddr_in($port, Socket::inet_aton($fromip));
    $DJabberd::Stats::counter{connect}++;

    my $self = $class->SUPER::new($sock, $server);
    $self->{db_result} = $db_result;

    $self->{final_cb}  = $final_cb;
    $self->{state}     = "connecting";

    $self->{conn}      = $conn;
    Scalar::Util::weaken($self->{conn});

    $self->watch_write(1);
}

sub event_write {
    my $self = shift;

    if ($self->{state} eq "connecting") {
        $self->{state} = "connected";
        $self->log->debug("$self->{id} connected for DialbackResult " . $self->{db_result}->orig_server);

lib/DJabberd/Connection/ServerOut.pm view on Meta::CPAN

    $ip = $endpt->addr;
    connect $sock, Socket::sockaddr_in($endpt->port, Socket::inet_aton($ip));
    $DJabberd::Stats::counter{connect}++;

    my $self = $class->SUPER::new($sock, $queue->vhost->server);
    $self->log->debug("Connecting to '$ip' for '$queue->{domain}'");
    $self->{state}     = "connecting";
    $self->{queue}     = $queue;
    $self->{vhost}     = $queue->vhost;

    Scalar::Util::weaken($self->{queue});

    return $self;
}

sub namespace {
    return "jabber:server";
}

sub start_connecting {
    my $self = shift;

lib/DJabberd/Connection/SimpleIn.pm view on Meta::CPAN

    my ($cmd, $rest) = ($1, $2);

    if ($cmd eq "set_vhost") {
        my $vhostname = $rest;
        my $vhost = $self->server->lookup_vhost($vhostname);
        unless ($vhost) {
            $self->write("ERROR no vhost '$vhostname'\n");
            return;
        }
        $self->{vhost} = $vhost;
        Scalar::Util::weaken($self->{vhost});
        $self->write("OK\n");
        return;
    }

    if ($cmd eq "send_xml") {
        my ($to, $enc_xml) = split(/\s+/, $rest);
        my $xml = durl($enc_xml);
        warn "SIMPLE: sending to '$to', the XML '$xml'\n";

        my $vhost = $self->vhost;

lib/DJabberd/Delivery.pm view on Meta::CPAN

}

sub vhost {
    return $_[0]->{vhost};
}

sub set_vhost {
    my ($self, $vhost) = @_;
    Carp::croak("Not a vhost: '$vhost'") unless UNIVERSAL::isa($vhost, "DJabberd::VHost");
    $self->{vhost} = $vhost;
    Scalar::Util::weaken($self->{vhost});
}

1;

lib/DJabberd/PresenceChecker.pm view on Meta::CPAN

    my ($class) = @_;
    return bless {}, $class;
}

sub vhost { $_[0]->{vhost} }

sub register {
    my ($self, $vhost) = @_;

    $self->{vhost} = $vhost;
    Scalar::Util::weaken($self->{vhost});

    # this is an odd hook, in that it wants to be called a lot, but the
    # normal hook chain system doesn't support that, so instead
    # this provides a cleaner interface for subclasses, which just call
    # 'add' and 'done', and this takes care of the ugliness of calling
    # the $add_cb callback.
    $vhost->register_hook("PresenceCheck", sub {
        my (undef, $cb, $jid, $add_cb) = @_;
        # cb can 'decline' only

lib/DJabberd/SAXHandler.pm view on Meta::CPAN

package DJabberd::SAXHandler;
use strict;
use base qw(XML::SAX::Base);
use DJabberd::XMLElement;
use DJabberd::StreamStart;
use Scalar::Util qw(weaken);
use Time::HiRes ();

sub new {
    my ($class, $conn) = @_;
    my $self = $class->SUPER::new;

    if ($conn) {
        $self->{"ds_conn"} = $conn;
        weaken($self->{ds_conn});
    }

    $self->{"capture_depth"} = 0;  # on transition from 1 to 0, stop capturing
    $self->{"on_end_capture"} = undef;  # undef or $subref->($doc)
    $self->{"events"} = [];  # capturing events
    return $self;
}

sub set_connection {
    my ($self, $conn) = @_;
    $self->{ds_conn} = $conn;
    if ($conn) {
        weaken($self->{ds_conn});
    } else {
        # when sax handler is being put back onto the freelist...
        $self->{on_end_capture} = undef;
    }
}

# called when somebody is about to destroy their reference to us, to make
# us clean up.
sub cleanup {
    my $self = shift;

lib/DJabberd/SAXHandler.pm view on Meta::CPAN

        $self->{capture_depth}++;
        return;
    }

    # start capturing...
    $self->{"events"} = [
                         [EVT_START_ELEMENT, $data],
                         ];
    $self->{capture_depth} = 1;

    Scalar::Util::weaken($conn);
    $self->{on_end_capture} = sub {
        my ($doc, $events) = @_;
        my $nodes = _nodes_from_events($events);
        # {=xml-stanza}
        my $t1 = Time::HiRes::time();
        $conn->on_stanza_received($nodes->[0]) if $conn;
        my $td = Time::HiRes::time() - $t1;

        # ring buffers for latency stats:
        if ($td > $DJabberd::Stats::latency_log_threshold) {

lib/DJabberd/Stanza.pm view on Meta::CPAN

            );

sub downbless {
    my $class = shift;
    if (ref $_[0]) {
        my ($self, $conn) = @_;
        my $new = fields::new($class);
        %$new = %$self; # copy fields
        if ($conn) {
            $new->{connection} = $conn;
            Scalar::Util::weaken($new->{connection});
        }
        return $new;
    } else {
        croak("Bogus use of downbless.");
    }

}

sub as_summary {
    my $self = shift;

lib/DJabberd/VHost.pm view on Meta::CPAN

}

sub server {
    my $self = shift;
    return $self->{server};
}

sub set_server {
    my ($self, $server) = @_;
    $self->{server} = $server;
    Scalar::Util::weaken($self->{server});
}

sub run_hook_chain {
    my $self = shift;
    my %opts = @_;

    my ($phase, $methods, $args, $fallback, $hook_inv)
        = @opts{qw(phase methods args fallback hook_invocant)};

    if (0) {

lib/DJabberd/XMLParser.pm view on Meta::CPAN

                # my ($sys_id, $pub_id) = @_;
                # warn "Received external entity: $sys_id:$pub_id";
                "";
            },
        });
        $libxml->set_handler($self);
        $self->{LibParser} = $libxml;

        # this buys nothing but less noise when using Devel::Cycle:
        # make it a developer option?
        # Scalar::Util::weaken($self->{LibParser});

        $libxml->init_push;
        $self->{CONTEXT} = $libxml->{CONTEXT};
    }

    # expat mode:
    if (0) {
        #use XML::SAX::Expat::Incremental;
        my $parser = XML::SAX::Expat::Incremental->new(Handler => $self);
        $self->{expat} = $parser;

t/hookchain.t view on Meta::CPAN

# -*-perl-*-

use strict;
use Test::More tests => 4;
use Scalar::Util qw(weaken);
use lib 't/lib';
require 'djabberd-test.pl';


my $server = DJabberd->new;
my $local = DJabberd::Delivery::Local->new();
my $vhost = DJabberd::VHost->new(server_name => "foo");
$vhost->add_plugin($local);
$server->add_vhost($vhost);
DJabberd::HookDocs->allow_hook("Foo");

t/hookchain.t view on Meta::CPAN


$vhost->register_hook("Foo", sub {
    my ($srv, $cb, @args) = @_;
    $cb->baz;
});

# testing an object in the args being destroyed
{
    my $obj = {};
    $track_obj = \$obj;
    weaken($track_obj);

    $vhost->run_hook_chain(phase   => "Foo",
                            args    => [ $obj, "arg2", "arg3" ],
                            methods => {
                                bar => sub {
                                    $outside = "bar!\n";
                                },
                                baz => sub {
                                    $outside = "baz!\n";
                                },

t/hookchain.t view on Meta::CPAN

                            fallback => sub {
                                print "fallback.\n";
                            });
}
is($track_obj, undef, "ref in args destroyed");

# testing an object in the callbacks being destroyed
{
    my $obj = {};
    $track_obj = \$obj;
    weaken($track_obj);

    $vhost->run_hook_chain(phase   => "Foo",
                            args    => [ "arg1", "arg2" ],
                            methods => {
                                bar => sub {
                                    $outside = "bar $obj!\n";
                                },
                                baz => sub {
                                    $outside = "baz $obj!\n";
                                },

t/hookchain.t view on Meta::CPAN

                            fallback => sub {
                                print "fallback.\n";
                            });
}
is($track_obj, undef, "ref in callbacks destroyed");

# testing an object in the fallback being destroyed
{
    my $obj = {};
    $track_obj = \$obj;
    weaken($track_obj);

    $vhost->run_hook_chain(phase   => "Foo",
                            args    => [ "arg1", "arg2" ],
                            methods => {
                                bar => sub {
                                    print "bar!\n";
                                },
                                baz => sub {
                                    $outside = "baz!\n";
                                },

t/hookchain.t view on Meta::CPAN

                            fallback => sub {
                                $outside = "fallback $obj.\n";
                            });
}
is($track_obj, undef, "ref in fallback destroyed");

# testing an object in the fallback being destroyed, when we execute the fallback
{
    my $obj = {};
    $track_obj = \$obj;
    weaken($track_obj);

    $vhost->run_hook_chain(phase   => "Nothing",
                            args    => [ "arg1", "arg2" ],
                            methods => {
                                bar => sub {
                                    print "bar!\n";
                                },
                                baz => sub {
                                    $outside = "baz!\n";
                                },

t/xmlparsing.t view on Meta::CPAN

#!/usr/bin/perl

use strict;
use warnings;
use XML::SAX;
use DJabberd::XMLParser;
use XML::SAX::PurePerl;
use Scalar::Util qw(weaken);
use Test::More tests => 14;
use Data::Dumper;

my $fulldoc = qq{<?xml version="1.0"?><root xmlns='root' xmlns:a='aa' global='foo' xmlns:b='bb' a:name='aname' b:name='bname' name='globalname'>
  <a:tag />
  <b:tag />
  <tag />
  </root>};

my $correct;

t/xmlparsing.t view on Meta::CPAN


my $dummy;
my $ref;

{
    my $handler = EventRecorder->new(\$dummy);
    my $p       = DJabberd::XMLParser->new(Handler => $handler);
    $p->finish_push;
    ok(!$dummy);
    $ref = \$p;
    weaken($ref);
}
ok(!$ref, "p went away");

{
    my $handler = EventRecorder->new(\$dummy);
    my $p       = DJabberd::XMLParser->new(Handler => $handler);
    $p->parse_more("<foo>&lt;<tag>");
    $p->finish_push;
    like($dummy, qr/foo.+tag/s);
    $ref = \$p;
    weaken($ref);
}
ok(!$ref, "p went away");

## external entities are disabled
{
    use FindBin;
    my $v = "$FindBin::Bin/v.txt";

    my $xml1 = <<"EOF";
<?xml version="1.0"?>

( run in 0.868 second using v1.01-cache-2.11-cpan-65fba6d93b7 )