#33286: Direct Debit by BillBuddy for Bank Accounts
[freeside.git] / FS / FS / addr_block.pm
1 package FS::addr_block;
2
3 use strict;
4 use vars qw( @ISA );
5 use FS::Record qw( qsearchs qsearch dbh );
6 use FS::router;
7 use FS::addr_range;
8 use FS::svc_broadband;
9 use FS::Conf;
10 use FS::IP_Mixin;
11 use NetAddr::IP;
12 use Carp qw( carp );
13 use List::Util qw( first );
14
15 @ISA = qw( FS::Record );
16
17 =head1 NAME
18
19 FS::addr_block - Object methods for addr_block records
20
21 =head1 SYNOPSIS
22
23   use FS::addr_block;
24
25   $record = new FS::addr_block \%hash;
26   $record = new FS::addr_block { 'column' => 'value' };
27
28   $error = $record->insert;
29
30   $error = $new_record->replace($old_record);
31
32   $error = $record->delete;
33
34   $error = $record->check;
35
36 =head1 DESCRIPTION
37
38 An FS::addr_block record describes an address block assigned for broadband 
39 access.  FS::addr_block inherits from FS::Record.  The following fields are 
40 currently supported:
41
42 =over 4
43
44 =item blocknum - primary key, used in FS::svc_broadband to associate 
45 services to the block.
46
47 =item routernum - the router (see FS::router) to which this 
48 block is assigned.
49
50 =item ip_gateway - the gateway address used by customers within this block.  
51
52 =item ip_netmask - the netmask of the block, expressed as an integer.
53
54 =item manual_flag - prohibit automatic ip assignment from this block when true. 
55
56 =item agentnum - optional agent number (see L<FS::agent>)
57
58 =back
59
60 =head1 METHODS
61
62 =over 4
63
64 =item new HASHREF
65
66 Create a new record.  To add the record to the database, see "insert".
67
68 =cut
69
70 sub table { 'addr_block'; }
71
72 =item insert
73
74 Adds this record to the database.  If there is an error, returns the error,
75 otherwise returns false.
76
77 =item delete
78
79 Deletes this record from the database.  If there is an error, returns the
80 error, otherwise returns false.
81
82 =cut
83
84 sub delete {
85   my $self = shift;
86   return 'Block must be deallocated and have no services before deletion'
87     if $self->router || $self->svc_broadband;
88
89     local $SIG{HUP} = 'IGNORE';
90     local $SIG{INT} = 'IGNORE';
91     local $SIG{QUIT} = 'IGNORE';
92     local $SIG{TERM} = 'IGNORE';
93     local $SIG{TSTP} = 'IGNORE';
94     local $SIG{PIPE} = 'IGNORE';
95
96     my $oldAutoCommit = $FS::UID::AutoCommit;
97     local $FS::UID::AutoCommit = 0;
98     my $dbh = dbh;
99     
100     my $error = $self->SUPER::delete;
101     if ( $error ) {
102        $dbh->rollback if $oldAutoCommit;
103        return $error;
104     }
105   
106     $dbh->commit or die $dbh->errstr if $oldAutoCommit;
107     '';
108 }
109
110
111 =item replace OLD_RECORD
112
113 Replaces OLD_RECORD with this one in the database.  If there is an error,
114 returns the error, otherwise returns false.
115
116 At present it's not possible to reallocate a block to a different router 
117 except by deallocating it first, which requires that none of its addresses 
118 be assigned.  This is probably as it should be.
119
120 sub replace_check {
121   my ( $new, $old ) = ( shift, shift );
122
123   unless($new->routernum == $old->routernum) {
124     my @svc = $self->svc_broadband;
125     if (@svc) {
126       return 'Block has assigned addresses: '.
127              join ', ', map {$_->ip_addr} @svc;
128     }
129
130     return 'Block is already allocated'
131       if($new->routernum && $old->routernum);
132
133   }
134
135   '';
136 }
137
138 =item check
139
140 Checks all fields to make sure this is a valid record.  If there is an error,
141 returns the error, otherwise returns false.  Called by the insert and replace
142 methods.
143
144 =cut
145
146 sub check {
147   my $self = shift;
148
149   my $error =
150     $self->ut_number('routernum')
151     || $self->ut_ip('ip_gateway')
152     || $self->ut_number('ip_netmask')
153     || $self->ut_enum('manual_flag', [ '', 'Y' ])
154     || $self->ut_agentnum_acl('agentnum', 'Broadband global configuration')
155   ;
156   return $error if $error;
157
158
159   # A routernum of 0 indicates an unassigned block and is allowed
160   return "Unknown routernum"
161     if ($self->routernum and not $self->router);
162
163   my $self_addr = $self->NetAddr;
164   return "Cannot parse address: ". $self->ip_gateway . '/' . $self->ip_netmask
165     unless $self_addr;
166
167   if (not $self->blocknum) {
168     my @block = grep {
169       my $block_addr = $_->NetAddr;
170       if($block_addr->contains($self_addr) 
171       or $self_addr->contains($block_addr)) { $_; };
172     } qsearch( 'addr_block', {});
173     foreach(@block) {
174       return "Block intersects existing block ".$_->ip_gateway."/".$_->ip_netmask;
175     }
176   }
177
178   $self->SUPER::check;
179 }
180
181
182 =item router
183
184 Returns the FS::router object corresponding to this object.  If the 
185 block is unassigned, returns undef.
186
187 =cut
188
189 sub router {
190   my $self = shift;
191   return qsearchs('router', { routernum => $self->routernum });
192 }
193
194 =item svc_broadband
195
196 Returns a list of FS::svc_broadband objects associated
197 with this object.
198
199 =cut
200
201 sub svc_broadband {
202   my $self = shift;
203   return qsearch('svc_broadband', { blocknum => $self->blocknum });
204 }
205
206 =item NetAddr
207
208 Returns a NetAddr::IP object for this block's address and netmask.
209
210 =cut
211
212 sub NetAddr {
213   my $self = shift;
214   new NetAddr::IP ($self->ip_gateway, $self->ip_netmask);
215 }
216
217 =item cidr
218
219 Returns a CIDR string for this block's address and netmask, i.e. 10.4.20.0/24
220
221 =cut
222
223 sub cidr {
224   my $self = shift;
225   $self->NetAddr->cidr;
226 }
227
228 =item next_free_addr
229
230 Returns a NetAddr::IP object corresponding to the first unassigned address 
231 in the block (other than the network, broadcast, or gateway address).  If 
232 there are no free addresses, returns nothing.  There are never free addresses
233 when manual_flag is true.
234
235 There is no longer a method to return all free addresses in a block.
236
237 =cut
238
239 sub next_free_addr {
240   my $self = shift;
241   my $selfaddr = $self->NetAddr;
242
243   return () if $self->manual_flag;
244
245   my $conf = new FS::Conf;
246   my @excludeaddr = $conf->config('exclude_ip_addr');
247
248   my %used = map { $_ => 1 }
249   (
250     @excludeaddr,
251     $selfaddr->addr,
252     $selfaddr->network->addr,
253     $selfaddr->broadcast->addr,
254     FS::IP_Mixin->used_addresses($self)
255   );
256
257   # just do a linear search of the block
258   my $freeaddr = $selfaddr->network + 1;
259   while ( $freeaddr < $selfaddr->broadcast ) {
260     # also make sure it's not blocked from assignment by an address range
261     if ( !$used{$freeaddr->addr } ) {
262       my ($range) = grep { !$_->allow_use }
263                   FS::addr_range->any_contains($freeaddr->addr);
264       if ( !$range ) {
265         # then we've found a free address
266         return $freeaddr;
267       }
268       # otherwise, skip to the end of the range
269       $freeaddr = NetAddr::IP->new($range->end, $self->ip_netmask);
270     }
271     $freeaddr++;
272   }
273   return;
274
275 }
276
277 =item allocate -- deprecated
278
279 Allocates this address block to a router.  Takes an FS::router object 
280 as an argument.
281
282 At present it's not possible to reallocate a block to a different router 
283 except by deallocating it first, which requires that none of its addresses 
284 be assigned.  This is probably as it should be.
285
286 =cut
287
288 sub allocate {
289   my ($self, $router) = @_;
290   carp "deallocate deprecated -- use replace";
291
292   return 'Block must be allocated to a router'
293     unless(ref $router eq 'FS::router');
294
295   my $new = new FS::addr_block {$self->hash};
296   $new->routernum($router->routernum);
297   return $new->replace($self);
298
299 }
300
301 =item deallocate -- deprecated
302
303 Deallocates the block (i.e. sets the routernum to 0).  If any addresses in the 
304 block are assigned to services, it fails.
305
306 =cut
307
308 sub deallocate {
309   carp "deallocate deprecated -- use replace";
310   my $self = shift;
311
312   my $new = new FS::addr_block {$self->hash};
313   $new->routernum(0);
314   return $new->replace($self);
315 }
316
317 =item split_block
318
319 Splits this address block into two equal blocks, occupying the same space as
320 the original block.  The first of the two will also have the same blocknum.
321 The gateway address of each block will be set to the first usable address, i.e.
322 (network address)+1.  Since this method is designed for use on unallocated
323 blocks, this is probably the correct behavior.
324
325 (At present, splitting allocated blocks is disallowed.  Anyone who wants to
326 implement this is reminded that each split costs three addresses, and any
327 customers who were using these addresses will have to be moved; depending on
328 how full the block was before being split, they might have to be moved to a
329 different block.  Anyone who I<still> wants to implement it is asked to tie it
330 to a configuration switch so that site admins can disallow it.)
331
332 =cut
333
334 sub split_block {
335
336   # We should consider using Attribute::Handlers/Aspect/Hook::LexWrap/
337   # something to atomicize functions, so that we can say 
338   #
339   # sub split_block : atomic {
340   # 
341   # instead of repeating all this AutoCommit verbage in every 
342   # sub that does more than one database operation.
343
344   my $oldAutoCommit = $FS::UID::AutoCommit;
345   local $FS::UID::AutoCommit = 0;
346   my $dbh = dbh;
347
348   my $self = shift;
349   my $error;
350
351   if ($self->router) {
352     return 'Block is already allocated';
353   }
354
355   #TODO: Smallest allowed block should be a config option.
356   if ($self->NetAddr->masklen() ge 30) {
357     return 'Cannot split blocks with a mask length >= 30';
358   }
359
360   my (@new, @ip);
361   $ip[0] = $self->NetAddr;
362   @ip = map {$_->first()} $ip[0]->split($self->ip_netmask + 1);
363
364   foreach (0,1) {
365     $new[$_] = new FS::addr_block {$self->hash};
366     $new[$_]->ip_gateway($ip[$_]->addr);
367     $new[$_]->ip_netmask($ip[$_]->masklen);
368   }
369
370   $new[1]->blocknum('');
371
372   $error = $new[0]->replace($self);
373   if ($error) {
374     $dbh->rollback;
375     return $error;
376   }
377
378   $error = $new[1]->insert;
379   if ($error) {
380     $dbh->rollback;
381     return $error;
382   }
383
384   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
385   return '';
386 }
387
388 =item merge
389
390 To be implemented.
391
392 =item agent
393
394 Returns the agent (see L<FS::agent>) for this address block, if one exists.
395
396 =cut
397
398 sub agent {
399   qsearchs('agent', { 'agentnum' => shift->agentnum } );
400 }
401
402 =item label
403
404 Returns text including the router name, gateway ip, and netmask for this
405 block.
406
407 =cut
408
409 sub label {
410   my $self = shift;
411   my $router = $self->router;
412   ($router ? $router->routername : '(unallocated)'). ':'. $self->NetAddr;
413 }
414
415 =head1 BUGS
416
417 Minimum block size should be a config option.  It's hardcoded at /30 right
418 now because that's the smallest block that makes any sense at all.
419
420 =cut
421
422 1;
423