1package DNS::LDNS::GC;
2
3use strict;
4use warnings;
5
6our $VERSION = '0.61';
7
8my %ref_count;
9my %owned_by;
10
11sub own {
12    my ($obj, $owner) = @_;
13
14#    print STDERR "Owning $obj -> $owner\n";
15    return unless (defined $obj);
16
17    if ($owned_by{$$owner}) {
18	# If the owner is an owned object, let obj be owned by
19	# the owners owner. We want to avoid recursive ownerships.
20	$owner = $owned_by{$$owner};
21    }
22
23    if (exists $owned_by{$$obj}) {
24	$ref_count{$$obj}++;
25    }
26    else {
27	$ref_count{$$obj} = 1;
28	$owned_by{$$obj} = $owner;
29    }
30    return $obj;
31}
32
33# Return true if the object is owned by someone
34sub is_owned {
35    return (exists $owned_by{${$_[0]}});
36}
37
38sub owner {
39    return $owned_by{${$_[0]}};
40}
41
42sub disown {
43    return unless (defined $_[0]);
44    delete $owned_by{${$_[0]}};
45}
46
47my %free_method = (
48    'DNS::LDNS::Zone'         => '_zone_deep_free',
49    'DNS::LDNS::RRList'       => '_rrlist_deep_free',
50    'DNS::LDNS::RR'           => '_rr_free',
51    'DNS::LDNS::RData'        => '_rdata_deep_free',
52    'DNS::LDNS::DNSSecZone'   => '_dnssec_zone_deep_free',
53    'DNS::LDNS::DNSSecName'   => '_dnssec_name_deep_free',
54    'DNS::LDNS::Resolver'     => '_resolver_deep_free',
55    'DNS::LDNS::Packet'       => '_packet_free',
56    'DNS::LDNS::Key'          => '_key_deep_free',
57    'DNS::LDNS::KeyList'      => '_keylist_free',
58    'DNS::LDNS::DNSSecDataChain' => '_dnssec_datachain',
59);
60
61my %not_deleted_by_owner = (
62    'DNS::LDNS::DNSSecTrustChain' => 1,
63);
64
65sub free {
66    my $obj = shift;
67
68#    print STDERR "Freeing $obj\n";
69
70    if (exists $ref_count{$$obj}) {
71#	print STDERR "Derefing $obj\n";
72	$ref_count{$$obj}--;
73	return if ($ref_count{$$obj} > 0);
74    }
75
76#    print STDERR "Deleting $obj\n";
77
78    delete $ref_count{$$obj};
79
80    if (exists $owned_by{$$obj}) {
81	delete $owned_by{$$obj};
82	return unless ($not_deleted_by_owner{ref $obj});
83    }
84
85    my $class = ref $obj;
86    my $free = $free_method{ref $obj};
87
88    die "Internal error: No freeing method for $obj (".ref $obj.")"
89	unless ($free);
90
91    no strict;
92    &$free($obj);
93}
94
951;
96__END__
97
98=head1 NAME
99
100DNS::LDNS::GC - Garbage collector, used internally by the DNS::LDNS modules
101
102=head1 SYNOPSIS
103
104Garbage collector class for DNS::LDNS objects.
105
106=head1 SEE ALSO
107
108http://www.nlnetlabs.nl/projects/ldns
109
110=head1 AUTHOR
111
112Erik Pihl Ostlyngen, E<lt>erik.ostlyngen@uninett.noE<gt>
113
114=head1 COPYRIGHT AND LICENSE
115
116Copyright (C) 2013 by UNINETT Norid AS
117
118This library is free software; you can redistribute it and/or modify
119it under the same terms as Perl itself, either Perl version 5.14.2 or,
120at your option, any later version of Perl 5 you may have available.
121
122=cut
123