1use warnings; 2use strict; 3 4use Carp; 5use Data::Dumper; 6use IPC::Shareable; 7use IPC::Shareable::SharedMem; 8use Test::More; 9use Test::SharedFork; 10 11sub shm_cleaned { 12 # --- shmread should barf if the segment has really been cleaned 13 my $id = shift; 14 my $data = ''; 15 16 eval { shmread($id, $data, 0, 6) or die "$!" }; 17 18 if ($@ && ($@ =~ /Invalid/ || $@ =~ /removed/)) { 19 return 1; 20 } 21 22 return 0; 23} 24 25# create not sent in 26{ 27 my $ret = eval { my $s = tie(my $sv, 'IPC::Shareable', 'child_sv', { destroy => 0 }); 1; }; 28 is $ret, undef, "We croak if a key is specified, create is not called and no segment exists"; 29 like $@, qr/ERROR: Could not acquire/, "...and error message is sane"; 30} 31 32# remove() (default IPC_PRIVATE) 33{ 34 my $s = tie my $sv, 'IPC::Shareable', { destroy => 0 }; 35 $sv = 'foobar'; 36 is $sv, 'foobar', "Default (IPC_PRIVATE) SV set and value is 'foobar'"; 37 38 my $id = $s->seg->id; 39 40 my $global = $s->global_register; 41 my $process = $s->process_register; 42 43 is keys %$global, 1, "Global register has one entry ok"; 44 is keys %$process, 1, "Process register has one entry ok"; 45 46 is exists $global->{$id}, 1, "ID $id exists in global register"; 47 is exists $global->{$id}, 1, "ID $id exists in process register"; 48 49 $s->remove; 50 51 is shm_cleaned($id), 1, "Default (IPC_PRIVATE) seg id $id removed after remove() ok"; 52 53 is keys %$global, 0, "Global register cleaned after remove()"; 54 is keys %$process, 0, "Process register cleaned after remove()"; 55} 56 57# remove() 58{ 59 my $s = tie my $sv, 'IPC::Shareable', 'test', { create => 1, destroy => 0 }; 60 $sv = 'foobar'; 61 is $sv, 'foobar', "SV set and value is 'foobar'"; 62 63 my $id = $s->seg->id; 64 65 my $global = $s->global_register; 66 my $process = $s->process_register; 67 68 is keys %$global, 1, "Global register has one entry ok"; 69 is keys %$process, 1, "Process register has one entry ok"; 70 71 is exists $global->{$id}, 1, "ID $id exists in global register"; 72 is exists $global->{$id}, 1, "ID $id exists in process register"; 73 74 $s->remove; 75 76 is shm_cleaned($id), 1, "seg id $id removed after remove() ok"; 77 78 is keys %$global, 0, "Global register cleaned after remove()"; 79 is keys %$process, 0, "Process register cleaned after remove()"; 80} 81 82# clean_up() 83{ 84 my $s = tie my $sv, 'IPC::Shareable', 'test', { create => 1, destroy => 0 }; 85 $sv = 'foobar'; 86 is $sv, 'foobar', "SV set and value is 'foobar'"; 87 88 my $id = $s->seg->id; 89 90 my $global = $s->global_register; 91 my $process = $s->process_register; 92 93 is keys %$global, 1, "Global register has one entry ok"; 94 is keys %$process, 1, "Process register has one entry ok"; 95 96 is exists $global->{$id}, 1, "ID $id exists in global register"; 97 is exists $global->{$id}, 1, "ID $id exists in process register"; 98 99 $s->clean_up; 100 101 is shm_cleaned($id), 1, "seg id $id removed after clean_up() ok"; 102 103 is keys %$global, 0, "Global register cleaned after clean_up()"; 104 is keys %$process, 0, "Process register cleaned after clean_up()"; 105} 106 107# clean_up_all() 108{ 109 my $s = tie my $sv, 'IPC::Shareable', 'test', { create => 1, destroy => 0 }; 110 $sv = 'foobar'; 111 is $sv, 'foobar', "SV set and value is 'foobar'"; 112 113 my $id = $s->seg->id; 114 115 my $global = $s->global_register; 116 my $process = $s->process_register; 117 118 is keys %$global, 1, "Global register has one entry ok"; 119 is keys %$process, 1, "Process register has one entry ok"; 120 121 is exists $global->{$id}, 1, "ID $id exists in global register"; 122 is exists $global->{$id}, 1, "ID $id exists in process register"; 123 124 $s->clean_up_all; 125 126 is shm_cleaned($id), 1, "seg id $id removed after clean_up_all() ok"; 127 128 is keys %$global, 0, "Global register cleaned after clean_up_all()"; 129 is keys %$process, 0, "Process register cleaned after clean_up_all()"; 130} 131 132my ($z, $y, $x, $w); 133 134# parent/child 135{ 136 my $awake = 0; 137 local $SIG{ALRM} = sub { $awake = 1 }; 138 139 my $pid = fork; 140 defined $pid or die "Cannot fork : $!"; 141 142 if ($pid == 0) { 143 # child 144 145 sleep unless $awake; 146 147 my $s = tie(my $sv, 'IPC::Shareable', 'kids', { destroy => 0 }); 148 $sv = 'baz'; 149 150 is $sv, 'baz', "SV initialized and set to 'baz' ok"; 151 152 IPC::Shareable->clean_up; 153 154 my $data = ''; 155 my $id = $s->seg->id; 156 157 shmread($id, $data, 0, length('IPC::Shareable')); 158 is $data, 'IPC::Shareable', "Shared memory alive ok in child"; 159 160 $s->clean_up; 161 162 is shm_cleaned($id), 0, "after clean_up(), all is well ok in child, we don't clean up what isn't ours"; 163 164 shmread($id, $data, 0, length('IPC::Shareable')); 165 is $data, 'IPC::Shareable', "SV doesn't get wiped if in a different proc w/clean_up()"; 166 167 exit; 168 } 169 else { 170 # parent 171 172 my $s = tie(my $sv, 'IPC::Shareable', 'kids', { create => 1, destroy => 0 }); 173 174 kill ALRM => $pid; 175 my $id = $s->seg->id; 176 waitpid($pid, 0); 177 178 is shm_cleaned($id), 0, "ID $id was not cleaned up in the child"; 179 180 is keys %{ $s->global_register }, 1, "Global register set before clean_up_all()"; 181 is keys %{ $s->process_register }, 1, "Process register set before clean_up_all()"; 182 183 IPC::Shareable->clean_up_all; 184 185 is keys %{ $s->global_register }, 0, "Global register cleaned with clean_up_all()"; 186 is keys %{ $s->process_register }, 0, "Process register cleaned with clean_up_all()"; 187 } 188} 189 190done_testing(); 191