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