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