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);
 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 =back
 416
 417 =head1 BUGS
 418
 419 Minimum block size should be a config option.  It's hardcoded at /30 right
 420 now because that's the smallest block that makes any sense at all.
 421
 422 =cut
 423
 424 1;
 425