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