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 a 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_in_block($self),
 253     FS::Conf->new()->config('exclude_ip_addr');
 254
 255   grep { !exists $used_addr_map{$_} } map { $_->addr } $self->NetAddr->hostenum;
 256 }
 257
 258 =item next_free_addr
 259
 260 Returns a NetAddr::IP object corresponding to the first unassigned address
 261 in the block (other than the network, broadcast, or gateway address).  If
 262 there are no free addresses, returns nothing.  There are never free addresses
 263 when manual_flag is true.
 264
 265 There is no longer a method to return all free addresses in a block.
 266
 267 =cut
 268
 269 sub next_free_addr {
 270   my $self = shift;
 271   my $selfaddr = $self->NetAddr;
 272
 273   return () if $self->manual_flag;
 274
 275   my $conf = new FS::Conf;
 276   my @excludeaddr = $conf->config('exclude_ip_addr');
 277
 278   my %used = map { $_ => 1 }
 279   (
 280     @excludeaddr,
 281     $selfaddr->addr,
 282     $selfaddr->network->addr,
 283     $selfaddr->broadcast->addr,
 284     FS::IP_Mixin->used_addresses($self)
 285   );
 286
 287   # just do a linear search of the block
 288   my $freeaddr = $selfaddr->network + 1;
 289   while ( $freeaddr < $selfaddr->broadcast ) {
 290     # also make sure it's not blocked from assignment by an address range
 291     if ( !$used{$freeaddr->addr } ) {
 292       my ($range) = grep { !$_->allow_use }
 293                   FS::addr_range->any_contains($freeaddr->addr);
 294       if ( !$range ) {
 295         # then we've found a free address
 296         return $freeaddr;
 297       }
 298       # otherwise, skip to the end of the range
 299       $freeaddr = NetAddr::IP->new($range->end, $self->ip_netmask);
 300     }
 301     $freeaddr++;
 302   }
 303   return;
 304
 305 }
 306
 307 =item allocate -- deprecated
 308
 309 Allocates this address block to a router.  Takes an FS::router object
 310 as an argument.
 311
 312 At present it's not possible to reallocate a block to a different router
 313 except by deallocating it first, which requires that none of its addresses
 314 be assigned.  This is probably as it should be.
 315
 316 =cut
 317
 318 sub allocate {
 319   my ($self, $router) = @_;
 320   carp "deallocate deprecated -- use replace";
 321
 322   return 'Block must be allocated to a router'
 323     unless(ref $router eq 'FS::router');
 324
 325   my $new = new FS::addr_block {$self->hash};
 326   $new->routernum($router->routernum);
 327   return $new->replace($self);
 328
 329 }
 330
 331 =item deallocate -- deprecated
 332
 333 Deallocates the block (i.e. sets the routernum to 0).  If any addresses in the
 334 block are assigned to services, it fails.
 335
 336 =cut
 337
 338 sub deallocate {
 339   carp "deallocate deprecated -- use replace";
 340   my $self = shift;
 341
 342   my $new = new FS::addr_block {$self->hash};
 343   $new->routernum(0);
 344   return $new->replace($self);
 345 }
 346
 347 =item split_block
 348
 349 Splits this address block into two equal blocks, occupying the same space as
 350 the original block.  The first of the two will also have the same blocknum.
 351 The gateway address of each block will be set to the first usable address, i.e.
 352 (network address)+1.  Since this method is designed for use on unallocated
 353 blocks, this is probably the correct behavior.
 354
 355 (At present, splitting allocated blocks is disallowed.  Anyone who wants to
 356 implement this is reminded that each split costs three addresses, and any
 357 customers who were using these addresses will have to be moved; depending on
 358 how full the block was before being split, they might have to be moved to a
 359 different block.  Anyone who I<still> wants to implement it is asked to tie it
 360 to a configuration switch so that site admins can disallow it.)
 361
 362 =cut
 363
 364 sub split_block {
 365
 366   # We should consider using Attribute::Handlers/Aspect/Hook::LexWrap/
 367   # something to atomicize functions, so that we can say
 368   #
 369   # sub split_block : atomic {
 370   #
 371   # instead of repeating all this AutoCommit verbage in every
 372   # sub that does more than one database operation.
 373
 374   my $oldAutoCommit = $FS::UID::AutoCommit;
 375   local $FS::UID::AutoCommit = 0;
 376   my $dbh = dbh;
 377
 378   my $self = shift;
 379   my $error;
 380
 381   if ($self->router) {
 382     return 'Block is already allocated';
 383   }
 384
 385   #TODO: Smallest allowed block should be a config option.
 386   if ($self->NetAddr->masklen() ge 30) {
 387     return 'Cannot split blocks with a mask length >= 30';
 388   }
 389
 390   my (@new, @ip);
 391   $ip[0] = $self->NetAddr;
 392   @ip = map {$_->first()} $ip[0]->split($self->ip_netmask + 1);
 393
 394   foreach (0,1) {
 395     $new[$_] = new FS::addr_block {$self->hash};
 396     $new[$_]->ip_gateway($ip[$_]->addr);
 397     $new[$_]->ip_netmask($ip[$_]->masklen);
 398   }
 399
 400   $new[1]->blocknum('');
 401
 402   $error = $new[0]->replace($self);
 403   if ($error) {
 404     $dbh->rollback;
 405     return $error;
 406   }
 407
 408   $error = $new[1]->insert;
 409   if ($error) {
 410     $dbh->rollback;
 411     return $error;
 412   }
 413
 414   $dbh->commit or die $dbh->errstr if $oldAutoCommit;
 415   return '';
 416 }
 417
 418 =item merge
 419
 420 To be implemented.
 421
 422 =item agent
 423
 424 Returns the agent (see L<FS::agent>) for this address block, if one exists.
 425
 426 =cut
 427
 428 sub agent {
 429   qsearchs('agent', { 'agentnum' => shift->agentnum } );
 430 }
 431
 432 =item label
 433
 434 Returns text including the router name, gateway ip, and netmask for this
 435 block.
 436
 437 =cut
 438
 439 sub label {
 440   my $self = shift;
 441   my $router = $self->router;
 442   ($router ? $router->routername : '(unallocated)'). ':'. $self->NetAddr;
 443 }
 444
 445 =head1 BUGS
 446
 447 Minimum block size should be a config option.  It's hardcoded at /30 right
 448 now because that's the smallest block that makes any sense at all.
 449
 450 =cut
 451
 452 1;