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