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