|  line  | 
 stmt  | 
 bran  | 
 cond  | 
 sub  | 
 pod  | 
 time  | 
 code  | 
| 
1
 | 
  
 
  
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 #!/usr/bin/perl  | 
| 
2
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 #-------------------------------------------------------------------------------  | 
| 
3
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 # Buddy system memory allocation in 100% Pure Perl  | 
| 
4
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 # Philip R Brenan at gmail dot com, Appa Apps Ltd, 2016  | 
| 
5
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 #-------------------------------------------------------------------------------  | 
| 
6
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
7
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 package Data::Layout::BuddySystem;  | 
| 
8
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 require v5.16.0;  | 
| 
9
 | 
1
 | 
 
 | 
 
 | 
  
1
  
 | 
 
 | 
654
 | 
 use warnings FATAL => qw(all);  | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
3
 | 
    | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
42
 | 
    | 
| 
10
 | 
1
 | 
 
 | 
 
 | 
  
1
  
 | 
 
 | 
8
 | 
 use strict;  | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
2
 | 
    | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
31
 | 
    | 
| 
11
 | 
1
 | 
 
 | 
 
 | 
  
1
  
 | 
 
 | 
617
 | 
 use Data::Table::Text qw(:all);  | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
31260
 | 
    | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
499
 | 
    | 
| 
12
 | 
1
 | 
 
 | 
 
 | 
  
1
  
 | 
 
 | 
14
 | 
 use Carp;  | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
3
 | 
    | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
2356
 | 
    | 
| 
13
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 our $VERSION = 20170808;  | 
| 
14
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
15
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 if (0)                                                                          # Save to S3:- this will not work, unless you're me, or you happen, to know the key  | 
| 
16
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
  {my $z = 'DataLayoutBuddySystem.zip';  | 
| 
17
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   print for qx(zip $z $0 && aws s3 cp $z s3://AppaAppsSourceVersions/$z && rm $z);  | 
| 
18
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
  }  | 
| 
19
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
20
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 #1 Methods  | 
| 
21
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub new                                                                         # Create a new Buddy system  | 
| 
22
 | 
76
 | 
 
 | 
 
 | 
  
76
  
 | 
  
1
  
 | 
1495
 | 
  {return bless {};  | 
| 
23
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
  }  | 
| 
24
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
25
 | 
52380
 | 
 
 | 
  
100
  
 | 
  
52380
  
 | 
  
0
  
 | 
120906
 | 
 sub freeChains{$_[0]{freeChains} //= []}                                        ## Addresses of free blocks organised by power of two size  | 
| 
26
 | 
4427
 | 
 
 | 
  
100
  
 | 
  
4427
  
 | 
  
0
  
 | 
24142
 | 
 sub usedSize  {$_[0]{usedSize}   //= {}}                                        ## {address} = size of allocation at that address  | 
| 
27
 | 
974
 | 
 
 | 
  
100
  
 | 
  
974
  
 | 
  
0
  
 | 
2085
 | 
 sub wentTo    {$_[0]{wentTo}     //= {}}                                        ## {address1} = address2 - where address 1 was relocated to by copy  | 
| 
28
 | 
991
 | 
 
 | 
  
100
  
 | 
  
991
  
 | 
  
0
  
 | 
2003
 | 
 sub cameFrom  {$_[0]{cameFrom}   //= {}}                                        ## {address1} = address2 - where address 1 came from before being copied  | 
| 
29
 | 
18415
 | 
 
 | 
  
100
  
 | 
  
18415
  
 | 
  
0
  
 | 
49846
 | 
 sub allFrees  {$_[0]{allFrees}   //= []}                                        ## [chain] = count of allocations minus frees on this chain  | 
| 
30
 | 
45
 | 
 
 | 
  
100
  
 | 
  
45
  
 | 
  
0
  
 | 
144
 | 
 sub nameAlloc {$_[0]{nameAlloc}  //= {}}                                        ## {name}  = name of allocation if a name has been supplied  | 
| 
31
 | 
45
 | 
 
 | 
  
100
  
 | 
  
45
  
 | 
  
0
  
 | 
122
 | 
 sub allocName {$_[0]{allocName}  //= {}}                                        ## {address}  = name of allocation at this address if a name has been supplied  | 
| 
32
 | 
11160
 | 
 
 | 
 
 | 
  
11160
  
 | 
  
0
  
 | 
15026
 | 
 sub size      {scalar @{$_[0]->freeChains}}                                     ## Number of free chains in use  | 
| 
 
 | 
11160
 | 
 
 | 
 
 | 
 
 | 
 
 | 
18256
 | 
    | 
| 
33
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
34
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub allocField($$$)                                                             # Allocate a block in the buddy system, give it a name that is invariant even after this buddy system has been copied to a new buddy system to compact its storage, and return the address of its location in the buddy system  | 
| 
35
 | 
18
 | 
 
 | 
 
 | 
  
18
  
 | 
  
1
  
 | 
42
 | 
  {my ($buddySystem, $name, $size) = @_;                                         # Buddy system, name of block, integer log2(size of allocation)  | 
| 
36
 | 
18
 | 
  
 50
  
 | 
 
 | 
 
 | 
 
 | 
38
 | 
   $name              or                                                         # Check name has been supplied  | 
| 
37
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
     confess "Name required";  | 
| 
38
 | 
18
 | 
  
 50
  
 | 
 
 | 
 
 | 
 
 | 
99
 | 
   $name =~ /\A\w+\Z/ or                                                         # Check that only word characters are being used to construct the field name  | 
| 
39
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
     confess "Name must consist of word characters, not: $name";  | 
| 
40
 | 
18
 | 
  
 50
  
 | 
 
 | 
 
 | 
 
 | 
45
 | 
   defined($buddySystem->nameAlloc->{$name}) and                                 # Check proposed name of allocation is not already in use  | 
| 
41
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
     confess "Name already defined: $name";  | 
| 
42
 | 
18
 | 
 
 | 
 
 | 
 
 | 
 
 | 
38
 | 
   my $alloc = $buddySystem->alloc($size);                                       # Perform allocation  | 
| 
43
 | 
18
 | 
 
 | 
 
 | 
 
 | 
 
 | 
37
 | 
   $buddySystem->nameAlloc->{$name}  = $alloc;                                   # Name to address of allocation  | 
| 
44
 | 
18
 | 
 
 | 
 
 | 
 
 | 
 
 | 
46
 | 
   $buddySystem->allocName->{$alloc} = $name;                                    # Address to name of allocation  | 
| 
45
 | 
18
 | 
 
 | 
 
 | 
 
 | 
 
 | 
272
 | 
   $alloc                                                                        # Return address of allocation  | 
| 
46
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
  } # allocField  | 
| 
47
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
48
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub alloc($$)                                                                   # Allocate a block and return its bit address  | 
| 
49
 | 
1117
 | 
 
 | 
 
 | 
  
1117
  
 | 
  
1
  
 | 
2406
 | 
  {my ($buddySystem, $size) = @_;                                                # Buddy system, integer log2(size of allocation)  | 
| 
50
 | 
1117
 | 
  
 50
  
 | 
 
 | 
 
 | 
 
 | 
2378
 | 
   $size >= 0          or confess "Size must be positive, not $size";  | 
| 
51
 | 
1117
 | 
  
 50
  
 | 
 
 | 
 
 | 
 
 | 
2228
 | 
   $size == int($size) or confess "Size must be integral, not $size";  | 
| 
52
 | 
1117
 | 
 
 | 
 
 | 
 
 | 
 
 | 
2016
 | 
   $buddySystem->allFrees->[$size]++;                                            # Count allocations and frees on this chain - alloc always works  | 
| 
53
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
54
 | 
1117
 | 
  
100
  
 | 
 
 | 
 
 | 
 
 | 
2225
 | 
   if ($buddySystem->size == 0)                                                  # Initial allocation  | 
| 
55
 | 
76
 | 
 
 | 
 
 | 
 
 | 
 
 | 
166
 | 
    {my $alloc = 0;                                                              # Allocation address  | 
| 
56
 | 
76
 | 
 
 | 
 
 | 
 
 | 
 
 | 
174
 | 
     $buddySystem->freeChains->[$size] = {};                                     # Create chain for initial allocation  | 
| 
57
 | 
76
 | 
 
 | 
 
 | 
 
 | 
 
 | 
173
 | 
     $buddySystem->usedSize->{$alloc} = $size;                                   # Save size of allocation at offset  | 
| 
58
 | 
76
 | 
 
 | 
 
 | 
 
 | 
 
 | 
1572
 | 
     return $alloc;                                                              # Return allocation  | 
| 
59
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    }  | 
| 
60
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
61
 | 
1041
 | 
 
 | 
 
 | 
 
 | 
 
 | 
1892
 | 
   for my $F($size..$buddySystem->size-1)                                        # Look for space on the free chains  | 
| 
62
 | 
1932
 | 
  
100
  
 | 
 
 | 
 
 | 
 
 | 
3356
 | 
    {if (my $f = $buddySystem->freeChains->[$F])                                 # Each chain  | 
| 
63
 | 
1885
 | 
  
100
  
 | 
 
 | 
 
 | 
 
 | 
4117
 | 
      {if (keys %$f)                                                             # Free chain with space  | 
| 
64
 | 
949
 | 
 
 | 
 
 | 
 
 | 
 
 | 
2830
 | 
        {for my $alloc(sort {$a <=> $b} keys %$f)                                # Allocation address  | 
| 
 
 | 
68
 | 
 
 | 
 
 | 
 
 | 
 
 | 
206
 | 
    | 
| 
65
 | 
949
 | 
 
 | 
 
 | 
 
 | 
 
 | 
1880
 | 
          {delete $f->{$alloc};  | 
| 
66
 | 
949
 | 
 
 | 
 
 | 
 
 | 
 
 | 
2162
 | 
           $buddySystem->usedSize->{$alloc} = $size;                             # Save size of allocation at offset  | 
| 
67
 | 
949
 | 
 
 | 
 
 | 
 
 | 
 
 | 
2286
 | 
           $buddySystem->freeChains->[$_]{$alloc + (1<<$_)}++ for $size..$F-1;   # Return excess space to lower chains  | 
| 
68
 | 
949
 | 
 
 | 
 
 | 
 
 | 
 
 | 
21714
 | 
           return $alloc;                                                        # Return allocation  | 
| 
69
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
          }  | 
| 
70
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
        }  | 
| 
71
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
      }  | 
| 
72
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    }  | 
| 
73
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
                                                                                 # No space on any free chain - start a new chain to hold the allocation  | 
| 
74
 | 
92
 | 
 
 | 
 
 | 
 
 | 
 
 | 
174
 | 
   my $s = $buddySystem->size;                                                   # Size less than current allocation  | 
| 
75
 | 
92
 | 
  
100
  
 | 
 
 | 
 
 | 
 
 | 
244
 | 
   if ($size < $s-1)  | 
| 
76
 | 
45
 | 
 
 | 
 
 | 
 
 | 
 
 | 
104
 | 
    {my $F = $buddySystem->freeChains->[$s] = {};                                # Create new chain  | 
| 
77
 | 
45
 | 
 
 | 
 
 | 
 
 | 
 
 | 
91
 | 
     my $alloc = (1<<($s-1));                                                    # Allocation address  | 
| 
78
 | 
45
 | 
 
 | 
 
 | 
 
 | 
 
 | 
112
 | 
     $buddySystem->usedSize->{$alloc} = $size;                                   # Allocation size  | 
| 
79
 | 
45
 | 
 
 | 
 
 | 
 
 | 
 
 | 
139
 | 
     $buddySystem->freeChains->[$_]{$alloc + (1<<$_)}++ for $size..$s-2;         # Spread excess space across lower chains  | 
| 
80
 | 
45
 | 
 
 | 
 
 | 
 
 | 
 
 | 
894
 | 
     return $alloc  | 
| 
81
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    }  | 
| 
82
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   else                                                                          # Size greater than or equal to current allocation  | 
| 
83
 | 
47
 | 
 
 | 
 
 | 
 
 | 
 
 | 
112
 | 
    {my $F = $buddySystem->freeChains->[$size+1] = {};                           # Create new chain  | 
| 
84
 | 
47
 | 
 
 | 
 
 | 
 
 | 
 
 | 
81
 | 
     my $alloc = (1<<$size);                                                     # Allocation address  | 
| 
85
 | 
47
 | 
 
 | 
 
 | 
 
 | 
 
 | 
84
 | 
     $buddySystem->usedSize->{$alloc} = $size;                                   # Allocation size  | 
| 
86
 | 
47
 | 
 
 | 
 
 | 
 
 | 
 
 | 
109
 | 
     for($s..$size)                                                              # Spread excess space across lower chains  | 
| 
87
 | 
51
 | 
 
 | 
 
 | 
 
 | 
 
 | 
107
 | 
      {my $i = $size-($_+1-$s);  | 
| 
88
 | 
51
 | 
 
 | 
 
 | 
 
 | 
 
 | 
87
 | 
       $buddySystem->freeChains->[$i]{(1<<$i)}++;  | 
| 
89
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
      }  | 
| 
90
 | 
47
 | 
 
 | 
 
 | 
 
 | 
 
 | 
983
 | 
     return $alloc                                                               # Return allocation  | 
| 
91
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    }  | 
| 
92
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
  } # alloc  | 
| 
93
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
94
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub locateAddress($$)                                                           # Find the current location of a block by its original address after it has been copied to a new buddy system  | 
| 
95
 | 
9
 | 
 
 | 
 
 | 
  
9
  
 | 
  
1
  
 | 
13
 | 
  {my ($buddySystem, $alloc) = @_;                                               # Buddy system, address at which the block was originally located  | 
| 
96
 | 
9
 | 
 
 | 
  
 66
  
 | 
 
 | 
 
 | 
20
 | 
   $buddySystem->wentTo->{$alloc} // $alloc                                      # The relocated address if there is one, else the current address  | 
| 
97
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
  } # locateAddress  | 
| 
98
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
99
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub locateName($$)                                                              # Find the current location of a named block after it has been copied to a new buddy system  | 
| 
100
 | 
9
 | 
 
 | 
 
 | 
  
9
  
 | 
  
1
  
 | 
16
 | 
  {my ($buddySystem, $name) = @_;                                                # Buddy system, name of the block  | 
| 
101
 | 
9
 | 
 
 | 
 
 | 
 
 | 
 
 | 
21
 | 
   my $alloc = $buddySystem->nameAlloc->{$name};                                 # Address of named block  | 
| 
102
 | 
9
 | 
  
 50
  
 | 
 
 | 
 
 | 
 
 | 
21
 | 
   defined($alloc) or confess "No such named block: $name";                      # Complain of no such block exists  | 
| 
103
 | 
9
 | 
 
 | 
 
 | 
 
 | 
 
 | 
18
 | 
   $buddySystem->locateAddress($alloc)                                           # The relocated address if there is one, else the current address  | 
| 
104
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
  } # locateName  | 
| 
105
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
106
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub sizeAddress($$)                                                             # Size of allocation at an address  | 
| 
107
 | 
9
 | 
 
 | 
 
 | 
  
9
  
 | 
  
0
  
 | 
14
 | 
  {my ($buddySystem, $address) = @_;                                             # Buddy system, address of allocation whiose size we want  | 
| 
108
 | 
9
 | 
 
 | 
 
 | 
 
 | 
 
 | 
32
 | 
   $buddySystem->{usedSize}{$address}                                            # Size of allocation at specified address  | 
| 
109
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
  } # sizeAddress  | 
| 
110
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
111
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub sizeName($$)                                                                # Size of a named allocation  | 
| 
112
 | 
9
 | 
 
 | 
 
 | 
  
9
  
 | 
  
0
  
 | 
1895
 | 
  {my ($buddySystem, $name) = @_;                                                # Buddy system, address of allocation whiose size we want  | 
| 
113
 | 
9
 | 
 
 | 
 
 | 
 
 | 
 
 | 
18
 | 
   my $address = $buddySystem->locateName($name);                                # Address of allocation  | 
| 
114
 | 
9
 | 
  
 50
  
 | 
 
 | 
 
 | 
 
 | 
19
 | 
   defined($address) or confess "No allocation with name $name";                 # Check allocation by this name exists  | 
| 
115
 | 
9
 | 
 
 | 
 
 | 
 
 | 
 
 | 
16
 | 
   $buddySystem->sizeAddress($address)                                           # Size of named allocation  | 
| 
116
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
  } # sizeName  | 
| 
117
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
118
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub freeName($$)                                                                # Free an allocated block via its name  | 
| 
119
 | 
  
0
  
 | 
 
 | 
 
 | 
  
0
  
 | 
  
1
  
 | 
0
 | 
  {my ($buddySystem, $name) = @_;                                                # Buddy system, name used to allocate block  | 
| 
120
 | 
  
0
  
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
   my $alloc = $buddySystem->locateName($name);                                  # Current address of named block  | 
| 
121
 | 
  
0
  
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
   delete $buddySystem->nameAlloc->{$name};                                      # Disassociate name from block  | 
| 
122
 | 
  
0
  
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
   $buddySystem->free($alloc);                                                   # Free block by address  | 
| 
123
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
  } # freeName  | 
| 
124
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
125
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub free($$)                                                                    # Free an allocation via its original allocation address  | 
| 
126
 | 
965
 | 
 
 | 
 
 | 
  
965
  
 | 
  
1
  
 | 
1899
 | 
  {my ($buddySystem, $alloc) = @_;                                               # Buddy system, original allocation address  | 
| 
127
 | 
965
 | 
 
 | 
 
 | 
 
 | 
 
 | 
1784
 | 
   my $s = delete $buddySystem->usedSize->{$alloc};                              # Size of allocation at this alloc  | 
| 
128
 | 
965
 | 
  
 50
  
 | 
 
 | 
 
 | 
 
 | 
1920
 | 
   return 0 unless defined($s);                                                  # No allocation present and so no free is possible  | 
| 
129
 | 
965
 | 
 
 | 
 
 | 
 
 | 
 
 | 
1771
 | 
   $buddySystem->allFrees->[$s]--;                                               # Count allocations and frees on this chain - free always works beyond this point  | 
| 
130
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
131
 | 
965
 | 
 
 | 
 
 | 
 
 | 
 
 | 
1624
 | 
   delete $buddySystem->usedSize->{$alloc};                                      # Remove information appertaining to this block  | 
| 
132
 | 
965
 | 
 
 | 
 
 | 
 
 | 
 
 | 
1721
 | 
   delete $buddySystem->wentTo->{$alloc};  | 
| 
133
 | 
965
 | 
 
 | 
 
 | 
 
 | 
 
 | 
1655
 | 
   delete $buddySystem->cameFrom->{$alloc};  | 
| 
134
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
135
 | 
965
 | 
 
 | 
 
 | 
 
 | 
 
 | 
1743
 | 
   my $S = $buddySystem->size-1;                                                 # Freeing will not make the system larger  | 
| 
136
 | 
965
 | 
 
 | 
 
 | 
 
 | 
 
 | 
2003
 | 
   for my $c($s..$S)                                                             # Merge buddies  | 
| 
137
 | 
1840
 | 
 
 | 
 
 | 
 
 | 
 
 | 
3018
 | 
    {my $f = $buddySystem->freeChains->[$c];                                     # Free chain involved  | 
| 
138
 | 
1840
 | 
 
 | 
 
 | 
 
 | 
 
 | 
2843
 | 
     my $C = (1<<($c+1));                                                        # Modulus to get upper or lower buddy of a pair  | 
| 
139
 | 
1840
 | 
 
 | 
 
 | 
 
 | 
 
 | 
3197
 | 
     my $u = $alloc % $C;                                                        # True if this the upper block of a buddy pair  | 
| 
140
 | 
1840
 | 
  
100
  
 | 
 
 | 
 
 | 
 
 | 
3766
 | 
     my $b = $alloc + ($u ? -$C : +$C) / 2;                                      # Locate possible buddy  | 
| 
141
 | 
1840
 | 
  
100
  
 | 
 
 | 
 
 | 
 
 | 
2923
 | 
     if (delete $buddySystem->freeChains->[$c]{$b})                              # Remove buddy if it exists  | 
| 
 
 | 
 
 | 
  
100
  
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
142
 | 
875
 | 
  
100
  
 | 
 
 | 
 
 | 
 
 | 
1969
 | 
      {$alloc = $u ? $b : $alloc;                                                # New block to place on next free chain  | 
| 
143
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
      }  | 
| 
144
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
     elsif ($c < $S)  | 
| 
145
 | 
919
 | 
 
 | 
 
 | 
 
 | 
 
 | 
1575
 | 
      {$buddySystem->freeChains->[$c]{$alloc}++;                                 # Place this unpaired block on free chain  | 
| 
146
 | 
919
 | 
 
 | 
 
 | 
 
 | 
 
 | 
21639
 | 
       return 1;                                                                 # Finished successfully - no block merges  | 
| 
147
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
      }  | 
| 
148
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
     else                                                                        # Remove excess free chains  | 
| 
149
 | 
46
 | 
 
 | 
 
 | 
 
 | 
 
 | 
79
 | 
      {my $c = $buddySystem->freeChains;  | 
| 
150
 | 
46
 | 
 
 | 
 
 | 
 
 | 
 
 | 
78
 | 
       my $a = $buddySystem->allFrees;  | 
| 
151
 | 
46
 | 
 
 | 
 
 | 
 
 | 
 
 | 
99
 | 
       for(1..@$c)                                                               # Remove a chain if it has nothing allocated  | 
| 
152
 | 
306
 | 
 
 | 
 
 | 
 
 | 
 
 | 
446
 | 
        {my $i = @$c-$_;  | 
| 
153
 | 
306
 | 
  
 50
  
 | 
 
 | 
 
 | 
 
 | 
672
 | 
         last if $a->[$i];  | 
| 
154
 | 
306
 | 
  
100
  
 | 
 
 | 
 
 | 
 
 | 
510
 | 
         pop @$a if $i < @$a;  | 
| 
155
 | 
306
 | 
 
 | 
 
 | 
 
 | 
 
 | 
505
 | 
         pop @$c;  | 
| 
156
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
        }  | 
| 
157
 | 
46
 | 
 
 | 
 
 | 
 
 | 
 
 | 
1142
 | 
       return 2;                                                                 # Finished successfully - one or more blocks were merged  | 
| 
158
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
      }  | 
| 
159
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    }  | 
| 
160
 | 
  
0
  
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
   confess "This code should be unreachable"                                     # Unreachable  | 
| 
161
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
  } # free  | 
| 
162
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
163
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 #2 Statistics                                                                   # These methods provide statistics on memory usage in the buddy system  | 
| 
164
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
165
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub usedSpace($)                                                                # Total allocated space in this buddy system  | 
| 
166
 | 
1100
 | 
 
 | 
 
 | 
  
1100
  
 | 
  
1
  
 | 
1717
 | 
  {my ($buddySystem) = @_;                                                       # Buddy system  | 
| 
167
 | 
1100
 | 
 
 | 
 
 | 
 
 | 
 
 | 
1626
 | 
   my $n = 0;  | 
| 
168
 | 
1100
 | 
 
 | 
 
 | 
 
 | 
 
 | 
2076
 | 
   my $u = $buddySystem->usedSize;  | 
| 
169
 | 
1100
 | 
 
 | 
 
 | 
 
 | 
 
 | 
56281
 | 
   $n += (1<<$u->{$_}) for keys %$u;  | 
| 
170
 | 
1100
 | 
 
 | 
 
 | 
 
 | 
 
 | 
7587
 | 
   $n  | 
| 
171
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
  } # usedSpace  | 
| 
172
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
173
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub freeSpace($)                                                                # Total free space that can still be allocated in this buddy system without changing its size  | 
| 
174
 | 
2099
 | 
 
 | 
 
 | 
  
2099
  
 | 
  
1
  
 | 
3472
 | 
  {my ($buddySystem) = @_;                                                       # Buddy system  | 
| 
175
 | 
2099
 | 
 
 | 
 
 | 
 
 | 
 
 | 
2924
 | 
   my $n = 0;  | 
| 
176
 | 
2099
 | 
 
 | 
 
 | 
 
 | 
 
 | 
3650
 | 
   for(0..$buddySystem->size-1)  | 
| 
177
 | 
32412
 | 
 
 | 
 
 | 
 
 | 
 
 | 
49937
 | 
    {my $f = $buddySystem->freeChains->[$_];  | 
| 
178
 | 
32412
 | 
  
100
  
 | 
 
 | 
 
 | 
 
 | 
54037
 | 
     next unless $f;  | 
| 
179
 | 
30218
 | 
 
 | 
 
 | 
 
 | 
 
 | 
50357
 | 
     $n += scalar(keys %$f) * (1<<$_);  | 
| 
180
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    }  | 
| 
181
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   $n  | 
| 
182
 | 
2099
 | 
 
 | 
 
 | 
 
 | 
 
 | 
3755
 | 
  } # freeSpace  | 
| 
183
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
184
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub totalSpace($)                                                               # Total space currently occupied by this buddy system  | 
| 
185
 | 
2371
 | 
 
 | 
 
 | 
  
2371
  
 | 
  
1
  
 | 
3880
 | 
  {my ($buddySystem) = @_;                                                       # Buddy system  | 
| 
186
 | 
2371
 | 
 
 | 
 
 | 
 
 | 
 
 | 
4046
 | 
   my $n = $buddySystem->size;  | 
| 
187
 | 
2371
 | 
  
100
  
 | 
 
 | 
 
 | 
 
 | 
4647
 | 
   return 0 unless $n;  | 
| 
188
 | 
2291
 | 
 
 | 
 
 | 
 
 | 
 
 | 
3614
 | 
   1 << ($buddySystem->size-1)                                                   # System invariant  | 
| 
189
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
  } # totalSpace  | 
| 
190
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
191
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub fractionalFreeSpace($)                                                      ## Fraction of space currently free vs total space  | 
| 
192
 | 
1015
 | 
 
 | 
 
 | 
  
1015
  
 | 
  
0
  
 | 
2469
 | 
  {my ($buddySystem) = @_;                                                       # Buddy system  | 
| 
193
 | 
1015
 | 
 
 | 
 
 | 
 
 | 
 
 | 
1951
 | 
   my $t = $buddySystem->totalSpace;  | 
| 
194
 | 
1015
 | 
 
 | 
 
 | 
 
 | 
 
 | 
1885
 | 
   my $f = $buddySystem->freeSpace;  | 
| 
195
 | 
1015
 | 
  
 50
  
 | 
 
 | 
 
 | 
 
 | 
1930
 | 
   return 1 unless $t > 0;  | 
| 
196
 | 
1015
 | 
 
 | 
 
 | 
 
 | 
 
 | 
23678
 | 
   $f / $t  | 
| 
197
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
  } # fractionalFreeSpace  | 
| 
198
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
199
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub checkSpace($)                                                               ## Check free space and used space match total space  | 
| 
200
 | 
1084
 | 
 
 | 
 
 | 
  
1084
  
 | 
  
0
  
 | 
2061
 | 
  {my ($buddySystem) = @_;                                                       # Buddy system  | 
| 
201
 | 
1084
 | 
 
 | 
 
 | 
 
 | 
 
 | 
1524
 | 
   my $b = $buddySystem;                                                         # Shorten  | 
| 
202
 | 
1084
 | 
 
 | 
 
 | 
 
 | 
 
 | 
2027
 | 
   my $u = $b->usedSpace;  | 
| 
203
 | 
1084
 | 
 
 | 
 
 | 
 
 | 
 
 | 
2280
 | 
   my $f = $b->freeSpace;  | 
| 
204
 | 
1084
 | 
 
 | 
 
 | 
 
 | 
 
 | 
1986
 | 
   my $t = $b->totalSpace;  | 
| 
205
 | 
1084
 | 
 
 | 
 
 | 
 
 | 
 
 | 
1676
 | 
   my $T = $u + $f;  | 
| 
206
 | 
1084
 | 
  
 50
  
 | 
 
 | 
 
 | 
 
 | 
2317
 | 
   confess "checkSpace failed used=$u free=$f used+free=$T != total=$t\n"  | 
| 
207
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 #   .dump($b)."\n"  | 
| 
208
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
     unless $u+$f == $t;  | 
| 
209
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
210
 | 
1084
 | 
 
 | 
 
 | 
 
 | 
 
 | 
1435
 | 
   if (1)                                                                        # Confirm used space matches allocated space  | 
| 
211
 | 
1084
 | 
 
 | 
 
 | 
 
 | 
 
 | 
1448
 | 
    {my $n = 0;  | 
| 
212
 | 
1084
 | 
 
 | 
 
 | 
 
 | 
 
 | 
2152
 | 
     for my $s(0..$b->size-1)                                                    # All the free chains  | 
| 
213
 | 
16287
 | 
 
 | 
  
100
  
 | 
 
 | 
 
 | 
25460
 | 
      {$n += ($b->allFrees->[$s]//0) * (1<<$s);                                  # Number of currently allocated blocks of this size  | 
| 
214
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
      }  | 
| 
215
 | 
1084
 | 
  
 50
  
 | 
 
 | 
 
 | 
 
 | 
2191
 | 
     confess "checkSpace failed used=$u n=$n"  | 
| 
216
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 #   .dump($b)."\n"  | 
| 
217
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
     unless $u == $n;  | 
| 
218
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    }  | 
| 
219
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
220
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   1  | 
| 
221
 | 
1084
 | 
 
 | 
 
 | 
 
 | 
 
 | 
26358
 | 
  } # checkSpace  | 
| 
222
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
223
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub visualise($$)                                                               ## Create a pictorial representation of the buddy system with free in lowercase and used in uppercase. Confess if free and used chains are inconsistent  | 
| 
224
 | 
82
 | 
 
 | 
 
 | 
  
82
  
 | 
  
0
  
 | 
202
 | 
  {my ($buddySystem, $title) = @_;                                               # BuddySystem, title  | 
| 
225
 | 
82
 | 
 
 | 
 
 | 
 
 | 
 
 | 
189
 | 
   my $S = $buddySystem->size;                                                   # Size of system  | 
| 
226
 | 
82
 | 
 
 | 
 
 | 
 
 | 
 
 | 
156
 | 
   my $L = 26;                                                                   # Length of alphabet  | 
| 
227
 | 
82
 | 
 
 | 
 
 | 
 
 | 
 
 | 
219
 | 
   my @A = map {chr(ord('a')-1+$_)} 1..$L;                                       # Use lowercase for free areas and upper case for used areas  | 
| 
 
 | 
2132
 | 
 
 | 
 
 | 
 
 | 
 
 | 
3448
 | 
    | 
| 
228
 | 
82
 | 
 
 | 
 
 | 
 
 | 
 
 | 
199
 | 
   my $e = 0; my $x = 0;                                                         # Number of error cells, number of cells examined  | 
| 
 
 | 
82
 | 
 
 | 
 
 | 
 
 | 
 
 | 
139
 | 
    | 
| 
229
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
230
 | 
82
 | 
 
 | 
 
 | 
 
 | 
 
 | 
200
 | 
   my @t = map {undef()} 1..$buddySystem->totalSpace;                            # Long representation  | 
| 
 
 | 
150481
 | 
 
 | 
 
 | 
 
 | 
 
 | 
185290
 | 
    | 
| 
231
 | 
82
 | 
 
 | 
 
 | 
 
 | 
 
 | 
2809
 | 
   for my $B(0..$S-1)                                                            # All the free/used blocks  | 
| 
232
 | 
543
 | 
 
 | 
 
 | 
 
 | 
 
 | 
797
 | 
    {my $s = (1<<$B);                                                            # Size of free blocks on this chain  | 
| 
233
 | 
543
 | 
  
100
  
 | 
 
 | 
 
 | 
 
 | 
967
 | 
     if (my $F = $buddySystem->freeChains->[$B])                                 # Free blocks of this size  | 
| 
234
 | 
223
 | 
 
 | 
 
 | 
 
 | 
 
 | 
759
 | 
      {for my $f(sort {$a <=> $b} keys %$F)                                      # Free block  | 
| 
 
 | 
12
 | 
 
 | 
 
 | 
 
 | 
 
 | 
59
 | 
    | 
| 
235
 | 
100
 | 
 
 | 
 
 | 
 
 | 
 
 | 
246
 | 
        {for(0..$s-1)                                                            # Each cell of free block  | 
| 
236
 | 
131634
 | 
 
 | 
 
 | 
 
 | 
 
 | 
171209
 | 
          {my $o = $f+$_;                                                        # Offset  | 
| 
237
 | 
131634
 | 
 
 | 
 
 | 
 
 | 
 
 | 
176009
 | 
           my $c = $A[$B % $L];                                                  # Marker character for free block  | 
| 
238
 | 
131634
 | 
 
 | 
 
 | 
 
 | 
 
 | 
157967
 | 
           ++$x;                                                                 # Examined cells count  | 
| 
239
 | 
131634
 | 
  
 50
  
 | 
 
 | 
 
 | 
 
 | 
189414
 | 
           if (defined($t[$o])) {++$e; $t[$o] = '*'} else {$t[$o] = $c}          # Do not overwrite previous free or used block  | 
| 
 
 | 
  
0
  
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
    | 
| 
 
 | 
  
0
  
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
    | 
| 
 
 | 
131634
 | 
 
 | 
 
 | 
 
 | 
 
 | 
211680
 | 
    | 
| 
240
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
          }  | 
| 
241
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
        }  | 
| 
242
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
      }  | 
| 
243
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    }  | 
| 
244
 | 
82
 | 
  
 50
  
 | 
 
 | 
 
 | 
 
 | 
176
 | 
   if (my $U = $buddySystem->usedSize)                                           # Used blocks  | 
| 
245
 | 
82
 | 
 
 | 
 
 | 
 
 | 
 
 | 
391
 | 
    {for my $u(sort {$a <=> $b} keys %$U)                                        # Used blocks in ascending order of offset  | 
| 
 
 | 
284
 | 
 
 | 
 
 | 
 
 | 
 
 | 
552
 | 
    | 
| 
246
 | 
216
 | 
 
 | 
 
 | 
 
 | 
 
 | 
408
 | 
      {my $s = $U->{$u};                                                         # Size of this used block  | 
| 
247
 | 
216
 | 
 
 | 
 
 | 
 
 | 
 
 | 
421
 | 
       for(1..(1<<$s))                                                           # Each cell of used block  | 
| 
248
 | 
18847
 | 
 
 | 
 
 | 
 
 | 
 
 | 
25242
 | 
        {my $o = $u+$_-1;                                                        # Offset  | 
| 
249
 | 
18847
 | 
 
 | 
 
 | 
 
 | 
 
 | 
25196
 | 
         my $c = $A[$s % $L];                                                    # Marker character for used block  | 
| 
250
 | 
18847
 | 
 
 | 
 
 | 
 
 | 
 
 | 
21946
 | 
         ++$x;  | 
| 
251
 | 
18847
 | 
  
 50
  
 | 
 
 | 
 
 | 
 
 | 
26684
 | 
         if (defined($t[$o])) {++$e; $t[$o] = '*'} else {$t[$o] = uc $c}         # Do not overwrite previous free or used block  | 
| 
 
 | 
  
0
  
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
    | 
| 
 
 | 
  
0
  
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
    | 
| 
 
 | 
18847
 | 
 
 | 
 
 | 
 
 | 
 
 | 
30956
 | 
    | 
| 
252
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
        }  | 
| 
253
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
      }  | 
| 
254
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    }  | 
| 
255
 | 
82
 | 
  
 50
  
 | 
  
 33
  
 | 
 
 | 
 
 | 
404
 | 
   if ($e or $x != $buddySystem->totalSpace)                                     # Inconsistent state detected  | 
| 
256
 | 
1
 | 
 
 | 
 
 | 
  
1
  
 | 
 
 | 
10
 | 
    {use Data::Dump qw(dump);  | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
3
 | 
    | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
44
 | 
    | 
| 
257
 | 
1
 | 
 
 | 
 
 | 
  
1
  
 | 
 
 | 
5
 | 
     use Carp;  | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
1
 | 
    | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
726
 | 
    | 
| 
258
 | 
  
0
  
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
     say STDOUT "Inconsistent State!";  | 
| 
259
 | 
  
0
  
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
     say STDOUT "  e=$e  x=$x length=", $buddySystem->totalSpace;  | 
| 
260
 | 
  
0
  
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
     say STDOUT "  ", dump($buddySystem);  | 
| 
261
 | 
  
0
  
 | 
 
 | 
  
  0
  
 | 
 
 | 
 
 | 
0
 | 
     say STDOUT '=', join '', map {$_//'*'} @t, "=";  | 
| 
 
 | 
  
0
  
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
    | 
| 
262
 | 
  
0
  
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
     confess "Inconsistent state";  | 
| 
263
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    }  | 
| 
264
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
265
 | 
82
 | 
 
 | 
 
 | 
 
 | 
 
 | 
212
 | 
   my @T = map {''} 1..$buddySystem->totalSpace;                                 # Short representation  | 
| 
 
 | 
150481
 | 
 
 | 
 
 | 
 
 | 
 
 | 
216495
 | 
    | 
| 
266
 | 
82
 | 
 
 | 
 
 | 
 
 | 
 
 | 
2879
 | 
   for my $B(0..$S-1)                                                            # All the free/used blocks  | 
| 
267
 | 
543
 | 
 
 | 
 
 | 
 
 | 
 
 | 
804
 | 
    {my $s = (1<<$B);                                                            # Size of free blocks on this chain  | 
| 
268
 | 
543
 | 
  
100
  
 | 
 
 | 
 
 | 
 
 | 
896
 | 
     if (my $F = $buddySystem->freeChains->[$B])                                 # Free blocks of this size  | 
| 
269
 | 
223
 | 
 
 | 
 
 | 
 
 | 
 
 | 
770
 | 
      {$T[$_] = $A[$B % $L] for sort {$a <=> $b} keys %$F;                       # Free block  | 
| 
 
 | 
12
 | 
 
 | 
 
 | 
 
 | 
 
 | 
62
 | 
    | 
| 
270
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
      }  | 
| 
271
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    }  | 
| 
272
 | 
82
 | 
  
 50
  
 | 
 
 | 
 
 | 
 
 | 
437
 | 
   if (my $U = $buddySystem->usedSize)                                           # Used blocks  | 
| 
273
 | 
82
 | 
 
 | 
 
 | 
 
 | 
 
 | 
300
 | 
    {for my $u(sort {$a <=> $b} keys %$U)                                        # Used blocks in ascending order of offset  | 
| 
 
 | 
284
 | 
 
 | 
 
 | 
 
 | 
 
 | 
771
 | 
    | 
| 
274
 | 
216
 | 
 
 | 
 
 | 
 
 | 
 
 | 
367
 | 
      {my $s = $U->{$u};                                                         # Size of this used block  | 
| 
275
 | 
216
 | 
 
 | 
 
 | 
 
 | 
 
 | 
465
 | 
       $T[$u] = uc $A[$s % $L];  | 
| 
276
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
      }  | 
| 
277
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    }  | 
| 
278
 | 
82
 | 
 
 | 
 
 | 
 
 | 
 
 | 
4421
 | 
   my $T = join '', @T;                                                          # Representation as a string  | 
| 
279
 | 
82
 | 
  
100
  
 | 
 
 | 
 
 | 
 
 | 
336
 | 
   say STDOUT "$title $T" if $title;  | 
| 
280
 | 
82
 | 
 
 | 
 
 | 
 
 | 
 
 | 
23138
 | 
   $T  | 
| 
281
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
  } # visualise  | 
| 
282
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
283
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 #2 Relocation                                                                   # These methods copy one buddy system to another compacting free space in the process.  | 
| 
284
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub copy($$;$)                                                                  # Copy a buddy system to compact its free space, the largest blocks are placed in (0) - ascending, (1) - descending order of size, blocks that get relocated to new positions in the new buddy system will still be accessible by their original address or name  | 
| 
285
 | 
2
 | 
 
 | 
 
 | 
  
2
  
 | 
  
1
  
 | 
7
 | 
  {my ($buddySystem, $order, $copy) = @_;                                        # Buddy system, order, optional copy method to copy an old allocation into its corresponding new allocation  | 
| 
286
 | 
2
 | 
 
 | 
 
 | 
 
 | 
 
 | 
9
 | 
   my $n = new;                                                                  # The new buddy system  | 
| 
287
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
288
 | 
2
 | 
  
 50
  
 | 
 
 | 
 
 | 
 
 | 
8
 | 
   if (my $u = $buddySystem->usedSize)                                           # Used blocks decreasing in size but increasing by address within each size  | 
| 
289
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    {my @u = sort  | 
| 
290
 | 
2
 | 
  
100
  
 | 
 
 | 
 
 | 
 
 | 
24
 | 
      {my $c = $order ? $u->{$b} <=> $u->{$a} : $u->{$a} <=> $u->{$b};           # 0 - Ascending, 1 - Descending order  | 
| 
 
 | 
71
 | 
 
 | 
 
 | 
 
 | 
 
 | 
115
 | 
    | 
| 
291
 | 
71
 | 
  
100
  
 | 
 
 | 
 
 | 
 
 | 
116
 | 
       return $c unless $c == 0;  | 
| 
292
 | 
14
 | 
 
 | 
 
 | 
 
 | 
 
 | 
37
 | 
       $a <=> $b                                                                 # Ascending address  | 
| 
293
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
      } keys %$u;  | 
| 
294
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
295
 | 
2
 | 
 
 | 
 
 | 
 
 | 
 
 | 
9
 | 
     for my $a(@u)                                                               # Each used block  | 
| 
296
 | 
26
 | 
 
 | 
 
 | 
 
 | 
 
 | 
37
 | 
      {my $size = $u->{$a};                                                      # Size of this block  | 
| 
297
 | 
26
 | 
 
 | 
 
 | 
 
 | 
 
 | 
33
 | 
       my $A;                                                                    # Address of relocated block  | 
| 
298
 | 
26
 | 
  
100
  
 | 
 
 | 
 
 | 
 
 | 
43
 | 
       if (my $name = $buddySystem->allocName->{$a})                             # Name attached to the block  | 
| 
299
 | 
9
 | 
 
 | 
 
 | 
 
 | 
 
 | 
16
 | 
        {$A = $n->allocField($name, $size);                                      # Create new block with same name in new buddy system  | 
| 
300
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
        }  | 
| 
301
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
       else  | 
| 
302
 | 
17
 | 
 
 | 
 
 | 
 
 | 
 
 | 
30
 | 
        {$A = $n->alloc($size);                                                  # Matching block in new buddy system  | 
| 
303
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
        }  | 
| 
304
 | 
26
 | 
  
 50
  
 | 
 
 | 
 
 | 
 
 | 
47
 | 
       $copy->($a, $A, $size) if $copy;                                          # Copy data from old block to new block, using the specified size  | 
| 
305
 | 
26
 | 
  
 50
  
 | 
 
 | 
 
 | 
 
 | 
42
 | 
       if (my $f = $buddySystem->cameFrom->{$a})                                 # Address this block originally came from if different from new address  | 
| 
306
 | 
  
0
  
 | 
  
  0
  
 | 
 
 | 
 
 | 
 
 | 
0
 | 
        {if ($f != $A)                                                           # Record new position if different  | 
| 
307
 | 
  
0
  
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
          {$n->cameFrom->{$A} = $f;                                              # The original address at which the block was allocated  | 
| 
308
 | 
  
0
  
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
           $n->wentTo  ->{$f} = $A;                                              # The current address of a block from its original address  | 
| 
309
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
          }  | 
| 
310
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
        }  | 
| 
311
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
      }  | 
| 
312
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    }  | 
| 
313
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   $n  | 
| 
314
 | 
2
 | 
 
 | 
 
 | 
 
 | 
 
 | 
27
 | 
  } # copy  | 
| 
315
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
316
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub copyLargestLast($;$)                                                        # Copy a buddy system, compacting free space, the new addresses of allocations can be found in wentTo, the largest blocks are placed last  | 
| 
317
 | 
1
 | 
 
 | 
 
 | 
  
1
  
 | 
  
1
  
 | 
3
 | 
  {my ($buddySystem, $copy) = @_;                                                # BuddySystem, copy method to copy an old allocation into a new allocation  | 
| 
318
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
5
 | 
   copy($buddySystem, 0, $copy);                                                 # Copy the buddy system  | 
| 
319
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
  } # copyLargestLast  | 
| 
320
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
321
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub copyLargestFirst($;$)                                                       # Copy a buddy system, compacting free space, the new addresses of allocations can be found in wentTo, the largest blocks are placed first  | 
| 
322
 | 
1
 | 
 
 | 
 
 | 
  
1
  
 | 
  
1
  
 | 
5
 | 
  {my ($buddySystem, $copy) = @_;                                                # BuddySystem, copy method to copy an old allocation into a new allocation  | 
| 
323
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
6
 | 
   copy($buddySystem, 1, $copy);                                                 # Copy the buddy system  | 
| 
324
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
  } # copyLargestFirst  | 
| 
325
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
326
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
327
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 #2 Structure                                                                    # This method generates a blessed sub whose methods provide named access to allocations backed by a L string  | 
| 
328
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub generateStructureFields($$)                                                 # Return a blessed sub whose methods access the named blocks in the buddy system. The blessed sub returns a text representation of the method definitions  | 
| 
329
 | 
1
 | 
 
 | 
 
 | 
  
1
  
 | 
  
1
  
 | 
3
 | 
  {my ($buddySystem, $package) = @_;                                             # Buddy system, structure name  | 
| 
330
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
5
 | 
   my $new    = $buddySystem->copyLargestLast;                                   # Organise the buddy system by element size  | 
| 
331
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
3
 | 
   my %allocs = %{$new->allocName};                                              # Named allocations  | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
3
 | 
    | 
| 
332
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
3
 | 
   my %sizes  = %{$new->usedSize};                                               # Size of each named allocation  | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
4
 | 
    | 
| 
333
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
5
 | 
   my $s = <
 | 
| 
334
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 package $package;  | 
| 
335
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 use utf8;  | 
| 
336
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 END  | 
| 
337
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
2
 | 
   my @s;  | 
| 
338
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
6
 | 
   for my $alloc(sort {$a<=>$b} keys %allocs)  | 
| 
 
 | 
20
 | 
 
 | 
 
 | 
 
 | 
 
 | 
27
 | 
    | 
| 
339
 | 
9
 | 
 
 | 
 
 | 
 
 | 
 
 | 
17
 | 
    {my $name = $allocs{$alloc};                                                 # Name of block  | 
| 
340
 | 
9
 | 
 
 | 
 
 | 
 
 | 
 
 | 
33
 | 
     my $size = $sizes{$alloc};                                                  # Log2 width of block  | 
| 
341
 | 
9
 | 
 
 | 
 
 | 
 
 | 
 
 | 
16
 | 
     my $bits = 2**$size;                                                        # Block size in vec terms  | 
| 
342
 | 
9
 | 
 
 | 
 
 | 
 
 | 
 
 | 
19
 | 
     my $offset = $alloc/$bits;                                                  # Block offset in vec terms  | 
| 
343
 | 
9
 | 
  
 50
  
 | 
 
 | 
 
 | 
 
 | 
48
 | 
     $offset == int($offset) or                                                  # Something has gone seriously wrong if this calculation fails to produce an integer  | 
| 
344
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
       confess "Offset should be an integer not $offset";  | 
| 
345
 | 
9
 | 
 
 | 
 
 | 
 
 | 
 
 | 
38
 | 
     push @s,                                                                    # Generate an lvalue sub to access the block by the assigned name  | 
| 
346
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
      ["sub $name", " :lvalue {vec(\$_[1], ", $offset.", ",  $bits, ")}\n"];  | 
| 
347
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    }  | 
| 
348
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
9
 | 
   $s .= formatTableBasic([@s]);                                                 # Layout the method definitions so they are easy to read  | 
| 
349
 | 
1
 | 
 
 | 
 
 | 
  
1
  
 | 
 
 | 
15
 | 
   eval $s;                                                                      # Generate methods  | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
  
2
  
 | 
 
 | 
4
 | 
    | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
  
2
  
 | 
 
 | 
11
 | 
    | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
  
0
  
 | 
 
 | 
744
 | 
    | 
| 
 
 | 
2
 | 
 
 | 
 
 | 
  
3
  
 | 
 
 | 
26
 | 
    | 
| 
 
 | 
2
 | 
 
 | 
 
 | 
  
3
  
 | 
 
 | 
49
 | 
    | 
| 
 
 | 
  
0
  
 | 
 
 | 
 
 | 
  
3
  
 | 
 
 | 
0
 | 
    | 
| 
 
 | 
3
 | 
 
 | 
 
 | 
  
0
  
 | 
 
 | 
36
 | 
    | 
| 
 
 | 
3
 | 
 
 | 
 
 | 
  
4
  
 | 
 
 | 
49
 | 
    | 
| 
 
 | 
3
 | 
 
 | 
 
 | 
  
1
  
 | 
 
 | 
32
 | 
    | 
| 
 
 | 
0
 | 
 
 | 
 
 | 
 
 | 
 
 | 
0
 | 
    | 
| 
 
 | 
4
 | 
 
 | 
 
 | 
 
 | 
 
 | 
50
 | 
    | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
19
 | 
    | 
| 
350
 | 
1
 | 
  
 50
  
 | 
 
 | 
 
 | 
 
 | 
191
 | 
   $@ and confess "$s\n$@";  | 
| 
351
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
4
 | 
   my $p = <
 | 
| 
352
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 bless sub {\$s}, "$package";  | 
| 
353
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 END  | 
| 
354
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
58
 | 
   my $P = eval $p;                                                              # Generate the blessed sub whose value is the text representation if its methods  | 
| 
355
 | 
1
 | 
  
 50
  
 | 
 
 | 
 
 | 
 
 | 
6
 | 
   $@ and confess "$p\n$@";  | 
| 
356
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
34
 | 
   $P  | 
| 
357
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
  } # generateStructureFields  | 
| 
358
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
359
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 # Test  | 
| 
360
 | 
1
 | 
  
 50
  
 | 
 
 | 
  
1
  
 | 
  
0
  
 | 
417
 | 
 sub test{eval join('', ) or die $@}  | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
  
1
  
 | 
 
 | 
33
 | 
    | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
  
1
  
 | 
 
 | 
5
 | 
    | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
398
 | 
    | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
49974
 | 
    | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
10
 | 
    | 
| 
 
 | 
1
 | 
 
 | 
 
 | 
 
 | 
 
 | 
211
 | 
    | 
| 
361
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
362
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 test unless caller;  | 
| 
363
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
364
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 # Documentation  | 
| 
365
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 #extractDocumentation() unless caller;                                          # Extract the documentation  | 
| 
366
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
367
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 1;  | 
| 
368
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
369
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 =encoding utf-8  | 
| 
370
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
371
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 =head1 Name  | 
| 
372
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
373
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 Data::Layout::BuddySystem - Layout data in memory allocated via a buddy system  | 
| 
374
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
375
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 =head1 Synopsis  | 
| 
376
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
377
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
  use Test::More tests=>10;  | 
| 
378
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
  use Data::Layout::BuddySystem;  | 
| 
379
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
  use utf8;  | 
| 
380
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
381
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
  my $b = Data::Layout::BuddySystem::new;                                        # Create a new buddy system  | 
| 
382
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
383
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
  $b->allocField(@$_) for                                                        # Allocate fields in the buddy system  | 
| 
384
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    [𝝳=>6], [𝝰=>0], [𝝙=>6],[𝝱=>0],[𝞈 =>4], [𝝺=>5], [𝝲=>0], [𝝖=>3], [𝝗=>3];       # Name and log2 size of each field  | 
| 
385
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
386
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
  my $s = $b->generateStructureFields('Struct');                                 # Generate structure definition  | 
| 
387
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
388
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
  ok nws($s->()) eq nws(<<'END');                                                # String representation of methods associated with generated structure  | 
| 
389
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 package Struct;  | 
| 
390
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 use utf8;  | 
| 
391
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub 𝝰    :lvalue {vec($_[1],   0,    1  )}  | 
| 
392
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub 𝝱    :lvalue {vec($_[1],   1,    1  )}  | 
| 
393
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub 𝝲    :lvalue {vec($_[1],   2,    1  )}  | 
| 
394
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub 𝝖    :lvalue {vec($_[1],   1,    8  )}  | 
| 
395
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub 𝝗    :lvalue {vec($_[1],   2,    8  )}  | 
| 
396
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub 𝞈   :lvalue {vec($_[1],   2,   16  )}  | 
| 
397
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub 𝝺    :lvalue {vec($_[1],   2,   32  )}  | 
| 
398
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub 𝝳    :lvalue {vec($_[1],   2,   64  )}  | 
| 
399
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 sub 𝝙    :lvalue {vec($_[1],   3,   64  )}  | 
| 
400
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 END  | 
| 
401
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
402
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   if (1)                                                                        # Set fields  | 
| 
403
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    {$s->𝝰(my $𝕄) = 1; ok $𝕄 eq "\1";  | 
| 
404
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
     $s->𝝱(   $𝕄) = 0; ok $𝕄 eq "\1";  | 
| 
405
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
     $s->𝝲(   $𝕄) = 1; ok $𝕄 eq "\5";  | 
| 
406
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
     $s->𝝖(   $𝕄) = 3; ok $𝕄 eq "\x05\x03";                                      # Byte fields  | 
| 
407
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
     $s->𝝗(   $𝕄) = 7; ok $𝕄 eq "\x05\x03\x07";  | 
| 
408
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
     $s->𝞈(   $𝕄) = 9; ok $𝕄 eq "\x05\x03\x07\x00\x00\x09";                      # Word field  | 
| 
409
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    }  | 
| 
410
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
411
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   if (1)                                                                        # Set and get an integer field  | 
| 
412
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    {$s->𝝺(my $𝕄) = 2; ok $s->𝝺($𝕄) == 2;                                        # Set field  | 
| 
413
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
     $s->𝝺(   $𝕄)++;   ok $s->𝝺($𝕄) == 3;                                        # Increment field  | 
| 
414
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
     ok $𝕄 eq "\0\0\0\0\0\0\0\0\0\0\0\3";                                        # Dump the memory organised by the buddy system  | 
| 
415
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    }  | 
| 
416
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
417
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 =head1 Description  | 
| 
418
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
419
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 Implements the buddy system described at L  | 
| 
420
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 in 100% Pure Perl.  Blocks can be identified by names or addresses which remain  | 
| 
421
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 invariant even after one buddy system has been copied to a new one to compact  | 
| 
422
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 free space. Each named allocation can be accessed via a generated method which  | 
| 
423
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 identifies an lvalue area of a L string used to back the memory  | 
| 
424
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 organised by the buddy system.  | 
| 
425
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
426
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
427
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 =head1 Methods  | 
| 
428
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
429
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 =head2 new()  | 
| 
430
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
431
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 Create a new Buddy system  | 
| 
432
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
433
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
434
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 =head2 allocField($buddySystem, $name, $size)  | 
| 
435
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
436
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 Allocate a block in the buddy system, give it a name that is invariant even after this buddy system has been copied to a new buddy system to compact its storage, and return the address of its location in the buddy system  | 
| 
437
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
438
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
      Parameter     Description  | 
| 
439
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   1  $buddySystem  Buddy system  | 
| 
440
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   2  $name         name of block  | 
| 
441
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   3  $size         integer log2(size of allocation)  | 
| 
442
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
443
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 =head2 alloc($buddySystem, $size)  | 
| 
444
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
445
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 Allocate a block and return its address  | 
| 
446
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
447
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
      Parameter     Description  | 
| 
448
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   1  $buddySystem  Buddy system  | 
| 
449
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   2  $size         integer log2(size of allocation)  | 
| 
450
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
451
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 =head2 locateAddress($buddySystem, $alloc)  | 
| 
452
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
453
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 Find the current location of a block by its original address after it has been copied to a new buddy system  | 
| 
454
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
455
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
      Parameter     Description  | 
| 
456
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   1  $buddySystem  Buddy system  | 
| 
457
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   2  $alloc        address at which the block was originally located  | 
| 
458
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
459
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 =head2 locateName($buddySystem, $name)  | 
| 
460
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
461
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 Find the current location of a named block after it has been copied to a new buddy system  | 
| 
462
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
463
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
      Parameter     Description  | 
| 
464
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   1  $buddySystem  Buddy system  | 
| 
465
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   2  $name         name of the block  | 
| 
466
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
467
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 =head2 freeName($buddySystem, $name)  | 
| 
468
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
469
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 Free an allocated block via its name  | 
| 
470
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
471
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
      Parameter     Description  | 
| 
472
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   1  $buddySystem  Buddy system  | 
| 
473
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   2  $name         name used to allocate block  | 
| 
474
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
475
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 =head2 free($buddySystem, $alloc)  | 
| 
476
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
477
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 Free an allocation via its original allocation address  | 
| 
478
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
479
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
      Parameter     Description  | 
| 
480
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   1  $buddySystem  Buddy system  | 
| 
481
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   2  $alloc        original allocation address  | 
| 
482
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
483
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 =head2 Statistics  | 
| 
484
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
485
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 These methods provide statistics on memory usage in the buddy system  | 
| 
486
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
487
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 =head3 usedSpace($buddySystem)  | 
| 
488
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
489
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 Total allocated space in this buddy system  | 
| 
490
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
491
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
      Parameter     Description  | 
| 
492
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   1  $buddySystem  Buddy system  | 
| 
493
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
494
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 =head3 freeSpace($buddySystem)  | 
| 
495
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
496
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 Total free space that can still be allocated in this buddy system without changing its size  | 
| 
497
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
498
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
      Parameter     Description  | 
| 
499
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   1  $buddySystem  Buddy system  | 
| 
500
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
501
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 =head3 totalSpace($buddySystem)  | 
| 
502
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
503
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 Total space currently occupied by this buddy system  | 
| 
504
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
505
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
      Parameter     Description  | 
| 
506
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   1  $buddySystem  Buddy system  | 
| 
507
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
508
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 =head2 Relocation  | 
| 
509
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
510
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 These methods copy one buddy system to another compacting free space in the process.  | 
| 
511
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
512
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 =head3 copy($buddySystem, $order, $copy)  | 
| 
513
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
514
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 Copy a buddy system to compact its free space, the largest blocks are placed in (0) - ascending, (1) - descending order of size, blocks that get relocated to new positions in the new buddy system will still be accessible by their original address or name  | 
| 
515
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
516
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
      Parameter     Description  | 
| 
517
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   1  $buddySystem  Buddy system  | 
| 
518
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   2  $order        order  | 
| 
519
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   3  $copy         optional copy method to copy an old allocation into its corresponding new allocation  | 
| 
520
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
521
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 =head3 copyLargestLast($buddySystem, $copy)  | 
| 
522
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
523
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 Copy a buddy system, compacting free space, the new addresses of allocations can be found in wentTo, the largest blocks are placed last  | 
| 
524
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
525
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
      Parameter     Description  | 
| 
526
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   1  $buddySystem  BuddySystem  | 
| 
527
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   2  $copy         copy method to copy an old allocation into a new allocation  | 
| 
528
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
529
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 =head3 copyLargestFirst($buddySystem, $copy)  | 
| 
530
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
531
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 Copy a buddy system, compacting free space, the new addresses of allocations can be found in wentTo, the largest blocks are placed first  | 
| 
532
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
533
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
      Parameter     Description  | 
| 
534
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   1  $buddySystem  BuddySystem  | 
| 
535
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   2  $copy         copy method to copy an old allocation into a new allocation  | 
| 
536
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
537
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 =head2 Structure  | 
| 
538
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
539
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 This method generates a blessed sub whose methods provide named access to allocations backed by a L string  | 
| 
540
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
541
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 =head3 generateStructureFields($buddySystem, $package)  | 
| 
542
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
543
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 Return a blessed sub whose methods access the named blocks in the buddy system. The blessed sub returns a text representation of the method definitions  | 
| 
544
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
545
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
      Parameter     Description  | 
| 
546
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   1  $buddySystem  Buddy system  | 
| 
547
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   2  $package      structure name  | 
| 
548
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
549
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 =head1 Index  | 
| 
550
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
551
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 The following methods will be exported by the :all tag  | 
| 
552
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
553
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 L  | 
| 
554
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 L  | 
| 
555
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 L  | 
| 
556
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 L  | 
| 
557
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 L  | 
| 
558
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 L  | 
| 
559
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 L  | 
| 
560
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 L  | 
| 
561
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 L  | 
| 
562
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 L  | 
| 
563
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 L  | 
| 
564
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 L  | 
| 
565
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 L  | 
| 
566
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 L  | 
| 
567
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
568
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 =head1 Installation  | 
| 
569
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
570
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 This module is written in 100% Pure Perl and is thus easy to read, modify and  | 
| 
571
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 install.  | 
| 
572
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
573
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 Standard Module::Build process for building and installing modules:  | 
| 
574
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
575
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   perl Build.PL  | 
| 
576
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   ./Build  | 
| 
577
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   ./Build test  | 
| 
578
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
   ./Build install  | 
| 
579
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
580
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 =head1 Author  | 
| 
581
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
582
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 philiprbrenan@gmail.com  | 
| 
583
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
584
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 http://www.appaapps.com  | 
| 
585
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
586
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 =head1 Copyright  | 
| 
587
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
588
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 Copyright (c) 2016 Philip R Brenan.  | 
| 
589
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
590
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 This module is free software. It may be used, redistributed and/or modified  | 
| 
591
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 under the same terms as Perl itself.  | 
| 
592
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
593
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 =cut  | 
| 
594
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
    | 
| 
595
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 
 | 
 __DATA__  |