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