← Back to branch summary

~ubuntu-branches/ubuntu/lucid/bioperl/lucid

« back to all changes in this revision

Viewing changes to examples/root_object/destroy.pl

  • Committer: Bazaar Package Importer
  • Author(s): Matt Hope
  • Date: 2004-04-18 14:24:11 UTC
  • mfrom: (1.2.1 upstream) (2.1.1 warty)
  • Revision ID: james.westby@ubuntu.com-20040418142411-gr92uexquw4w8liq
Tags: 1.4-1
* New upstream release
* Examples and working code are installed by default to usr/bin,
  this has been moved to usr/share/doc/bioperl/bin

Show diffs side-by-side

added added

removed removed

Lines of Context:
examples/root_object/destroy.pl
1
 
#!/usr/bin/perl -w
2
 
 
3
 
#---------------------------------------------------------------------------
4
 
# PROGRAM : destroy.pl
5
 
# PURPOSE : A basic driver script for testing destruction of Bio::Root::Object.pm
6
 
#           references and parent-child relationships.
7
 
# AUTHOR  : Steve Chervitz (sac@bioperl.org)
8
 
# CREATED : 3 Nov 1996
9
 
# REVISION: $Id: destroy.pl,v 1.3 2002/01/11 08:05:40 sac Exp $
10
 
# INSTALLATION
11
 
#    Edit the use lib "...." line to point the directory
12
 
#    containing your Bioperl modules.
13
 
#---------------------------------------------------------------------------
14
 
 
15
 
use lib "/home/steve/perl/bioperl";
16
 
use Bio::Root::Object ();    
17
 
use Bio::Root::Global qw(:std);    
18
 
use Foo               ();
19
 
use Outer             ();
20
 
 
21
 
print "\nParent-child driver.";
22
 
print "\n---------------------\n";
23
 
 
24
 
select(STDOUT); $| = 1;
25
 
my @errs = ();
26
 
my (@objs, $foo, $bar);
27
 
 
28
 
########################################
29
 
# Main
30
 
 
31
 
&parent_child;
32
 
 
33
 
&create_obj(2000);
34
 
print "Verify memory usage and hit <RETURN> to continue.";<STDIN>;
35
 
 
36
 
&destroy;
37
 
print "Verify memory usage and hit <RETURN> to continue.";<STDIN>;
38
 
 
39
 
&create_obj(2000);
40
 
print "Verify memory usage and hit <RETURN> to continue.";<STDIN>;
41
 
 
42
 
&test;
43
 
print "Verify memory usage and hit <RETURN> to continue.";<STDIN>;
44
 
 
45
 
exit 0;
46
 
 
47
 
 
48
 
#-----------------
49
 
sub create_obj {
50
 
#-----------------
51
 
# Create Foo objects
52
 
 
53
 
    my $num = shift || 1;
54
 
 
55
 
    print "\n-------------------------------------------------------------\n";
56
 
    print "Create Objects\n";
57
 
    print "-------------------------------------------------------------\n\n";
58
 
 
59
 
    foreach(1..$num) {
60
 
       push @objs, new Foo(-NAME   =>"foo$_",
61
 
                           -FOO    =>150, 
62
 
                           -BAR    =>250, 
63
 
                           -COLOR  =>'crimson',
64
 
                           -FLAVOR =>'lemon-lime',
65
 
                           -VERBOSE=> 1,    
66
 
                           );
67
 
    }
68
 
    print "\nCreated $num Foo objects.\n";
69
 
}
70
 
 
71
 
 
72
 
#-----------------
73
 
sub parent_child {
74
 
#-----------------
75
 
# Test the _drop_child() method (considered a 'protected' method; end-users 
76
 
# don't need to call this method in the normal course of affairs).
77
 
# Also shows the use of the global debug() function;
78
 
 
79
 
    print "\n-------------------------------------------------------------\n";
80
 
    print "Parent-Child Tester\n";
81
 
    print "-------------------------------------------------------------\n\n";
82
 
 
83
 
#    debug(1);
84
 
 
85
 
    my $foo = new Foo(-NAME   =>"BigFoo",
86
 
                      -FOO    =>15000, 
87
 
                      -BAR    =>250, 
88
 
                      -COLOR  =>'crimson',
89
 
                      -FLAVOR =>'lemon-lime',
90
 
                      -VERBOSE=> 1);
91
 
 
92
 
    print "\nAttempting to get the Foo object to drop its Bar child...\n";
93
 
    $bar = $foo->bar;
94
 
 
95
 
    $bar->parent->_drop_child($bar);
96
 
    printf "%s is still alive and knows its parent (%s), but it is orphaned.\n", $bar->to_string, $bar->parent->to_string;
97
 
    debug(0);
98
 
 
99
 
    print "\nHere's proof: attempt to drop the Bar child again...\n";
100
 
    eval { $bar->parent->_drop_child($bar); };
101
 
    if($@) {print $@; }
102
 
 
103
 
    debug(1);
104
 
 
105
 
    printf "\nAdding %s back to %s as an array data member\n",  $bar->to_string, $bar->parent->to_string;
106
 
    $bar->parent->{'array_member'}->[0] = $bar;
107
 
    $bar->parent->_drop_child($bar);
108
 
    
109
 
    printf "\nAdding %s back to %s as a hash data member\n",  $bar->to_string, $bar->parent->to_string;
110
 
    $bar->parent->{'hash_member'}->{'bar'} = $bar;
111
 
    $bar->parent->_drop_child($bar);
112
 
 
113
 
    debug(0);
114
 
    
115
 
    print "\nTry to drop the Bar child again...\n";
116
 
    eval { $bar->parent->_drop_child($bar); };
117
 
    if($@) {print $@; }
118
 
 
119
 
    # Add Bar back to Foo for further processing.
120
 
    $foo->{'Bar'} = $bar;
121
 
}
122
 
 
123
 
 
124
 
#-----------------
125
 
sub destroy {
126
 
#-----------------
127
 
    print "\n-------------------------------------------------------------\n";
128
 
    print "Destroy\n";
129
 
    print "-------------------------------------------------------------\n\n";
130
 
 
131
 
#    debug(2);
132
 
        if( ref $bar) {
133
 
#           print "\nDESTROYING BAR....\n";
134
 
            $bar->destroy;
135
 
            undef $bar;
136
 
        } 
137
 
 
138
 
    while($_ = shift @objs) {
139
 
        if (ref $_) {
140
 
#           $_->display;  # uncomment this to check for creation/destruction of IOManagers
141
 
#           printf "\nDESTROYING OBJ #%s:  $_....\n", scalar @objs;
142
 
            $_->destroy if ref $_;
143
 
            undef $_;
144
 
#           <STDIN>;
145
 
        }
146
 
    }
147
 
}
148
 
 
149
 
 
150
 
#-----------------
151
 
sub test {
152
 
#-----------------
153
 
    print "\n-------------------------------------------------------------\n";
154
 
    print "Test\n";
155
 
    print "-------------------------------------------------------------\n\n";
156
 
 
157
 
    print "Is foo alive?\n";
158
 
    print "Foo: $foo\nBar: $bar\n";
159
 
 
160
 
    print "\nAssigning onto foo.\n";
161
 
    $foo = "123456";
162
 
 
163
 
    print "Foo: $foo\n";
164
 
 
165
 
}