File Coverage

blib/lib/Acme/SexualReproduction.pm
Criterion Covered Total %
statement 41 41 100.0
branch 10 16 62.5
condition 1 3 33.3
subroutine 9 9 100.0
pod 2 2 100.0
total 63 71 88.7


line stmt bran cond sub pod time code
1             package Acme::SexualReproduction;
2              
3 4     4   29599 use 5.006;
  4         16  
  4         400  
4 4     4   37 use strict;
  4         6  
  4         127  
5 4     4   22 use warnings;
  4         14  
  4         153  
6 4     4   25 use Carp qw(carp croak);
  4         8  
  4         327  
7 4     4   4719 use IPC::Shareable ':lock';
  4         102677  
  4         785  
8              
9             our @EXPORT_OK = qw(male female);
10 4     4   46 use Exporter 'import';
  4         9  
  4         1820  
11              
12             =head1 NAME
13              
14             Acme::SexualReproduction - beacuse fork() is for unicellular ones.
15              
16             =head1 VERSION
17              
18             Version 0.01
19              
20             =cut
21              
22             our $VERSION = '0.01';
23              
24              
25             =head1 SYNOPSIS
26              
27             This module allows you to improve the chances of your program kind to survive by mixing genes of their processes when creating a child process. Especially if your program is a K-strategic one.
28              
29             In a "female" process:
30              
31             use Acme::SexualReproduction 'female';
32             my $pid = female('unique ID', \%chromosomes);
33             ...
34              
35             In a "male" process:
36              
37             use Acme::SexualReproduction 'male';
38             male('unique ID', \%chromosomes);
39              
40             The child is spawned then from the female process.
41              
42             =head1 EXPORT
43              
44             Only two functions are exported: one for insemination (a "male" process) and one for allocating a shared hash of chromosomes and spawning a child (a "female" process).
45              
46             =head2 male($id, \%chromosomes);
47              
48             Tries to write the chromosomes to the shared memory of the female process with unique SHM $id. Sadly, does not return the child's PID.
49              
50             =cut
51              
52             =for comment
53             This subroutine was written first just because it was easier. I strongly disclaim any sexual discrimination from my side. It's written just for fun anyways.
54             =cut
55              
56             sub male {
57 1     1 1 1001260 my ($id, $chromosomes) = @_;
58 1 50       113 croak "\$chromosomes must be a HASH reference" unless ref $chromosomes eq 'HASH';
59 1 50       22 croak "Male process is sterile" unless keys %$chromosomes;
60 1   33     68 tie my $sperm, 'IPC::Shareable', { key => $id } || croak "Couldn't copulate with female process, SHM ID $id: $!";
61 1         1058 (tied $sperm)->shlock;
62 1         1064 @{$sperm}{keys %$chromosomes} = values %$chromosomes;
  1         9  
63 1         988 (tied $sperm)->shunlock;
64 1         33 return 1;
65             }
66              
67             =head2 $pid = female($id, \%chromosomes)
68              
69             Shares a hash for the male process' chromosomes, waits for the insemination, mixes the genes and spawns the child process. \%chromosomes hash reference is changed in the child process.
70              
71             =cut
72              
73             sub female {
74 2     2 1 3348 my ($id, $chromosomes) = @_;
75 2 50       522 croak "\$chromosomes must be a HASH reference" unless ref $chromosomes eq 'HASH';
76 2 50       408 tie my $sperm, 'IPC::Shareable', {key => $id, create => 1 } or carp("Couldn't copulate with male process: $!"), return;
77 2         3298 sleep 0.5 while !keys %$sperm; # foreplay
78 2 50       2001616 keys %$sperm eq keys %$chromosomes or carp("Chromosome mismatch"), return;
79 2 100       822 my %child_chromosomes = map { $_, int rand 2 ? $chromosomes->{$_} : $sperm->{$_} } keys %$chromosomes;
  4         38  
80 2         2837 my $pid = fork;
81 2 50       142 carp("Couldn't spawn a child: $!"), return unless defined $pid;
82 2 100       136 %$chromosomes = %child_chromosomes if $pid == 0;
83 2         190 return $pid;
84             }
85              
86             =head1 AUTHOR
87              
88             Ivan Krylov, C<< >>
89              
90             =head1 BUGS
91              
92             Please report any bugs or feature requests to C, or through
93             the web interface at L. I will be notified, and then you'll
94             automatically be notified of progress on your bug as I make changes.
95              
96              
97              
98              
99             =head1 SUPPORT
100              
101             You can find documentation for this module with the perldoc command.
102              
103             perldoc Acme::SexualReproduction
104              
105              
106             You can also look for information at:
107              
108             =over 4
109              
110             =item * RT: CPAN's request tracker (report bugs here)
111              
112             L
113              
114             =item * AnnoCPAN: Annotated CPAN documentation
115              
116             L
117              
118             =item * CPAN Ratings
119              
120             L
121              
122             =item * Search CPAN
123              
124             L
125              
126             =back
127              
128              
129             =head1 ACKNOWLEDGEMENTS
130              
131              
132             =head1 LICENSE AND COPYRIGHT
133              
134             Copyright 2013 Ivan Krylov.
135              
136             This program is free software; you can redistribute it and/or modify it
137             under the terms of either: the GNU General Public License as published
138             by the Free Software Foundation; or the Artistic License.
139              
140             See http://dev.perl.org/licenses/ for more information.
141              
142              
143             =cut
144              
145 4     4   24 no warnings 'void';
  4         11  
  4         247  
146             "fork() is for unicellar organisms!";