FS/FS/part_pkg_link.pm

   1 package FS::part_pkg_link;
   2
   3 use strict;
   4 use vars qw( @ISA );
   5 use FS::Record qw( qsearchs qsearch dbh );
   6 use FS::part_pkg;
   7 use FS::cust_pkg;
   8 use FS::reason;
   9 use FS::reason_type;
  10
  11 @ISA = qw(FS::Record);
  12
  13 =head1 NAME
  14
  15 FS::part_pkg_link - Object methods for part_pkg_link records
  16
  17 =head1 SYNOPSIS
  18
  19   use FS::part_pkg_link;
  20
  21   $record = new FS::part_pkg_link \%hash;
  22   $record = new FS::part_pkg_link { 'column' => 'value' };
  23
  24   $error = $record->insert;
  25
  26   $error = $new_record->replace($old_record);
  27
  28   $error = $record->delete;
  29
  30   $error = $record->check;
  31
  32 =head1 DESCRIPTION
  33
  34 An FS::part_pkg_link object represents an link from one package definition to
  35 another.  FS::part_pkg_link inherits from FS::Record.  The following fields are
  36 currently supported:
  37
  38 =over 4
  39
  40 =item pkglinknum
  41
  42 primary key
  43
  44 =item src_pkgpart
  45
  46 Source package (see L<FS::part_pkg>)
  47
  48 =item dst_pkgpart
  49
  50 Destination package (see L<FS::part_pkg>)
  51
  52 =item link_type
  53
  54 Link type - currently, "bill" (source package bills a line item from target
  55 package), or "svc" (source package includes services from target package),
  56 or "supp" (ordering source package creates a target package).
  57
  58 =item hidden
  59
  60 Flag indicating that this subpackage should be felt, but not seen as an invoice
  61 line item when set to 'Y'.  Not allowed for "supp" links.
  62
  63 =back
  64
  65 =head1 METHODS
  66
  67 =over 4
  68
  69 =item new HASHREF
  70
  71 Creates a new link.  To add the link to the database, see L<"insert">.
  72
  73 Note that this stores the hash reference, not a distinct copy of the hash it
  74 points to.  You can ask the object for a copy with the I<hash> method.
  75
  76 =cut
  77
  78 # the new method can be inherited from FS::Record, if a table method is defined
  79
  80 sub table { 'part_pkg_link'; }
  81
  82 =item insert
  83
  84 Adds this record to the database.  If there is an error, returns the error,
  85 otherwise returns false.
  86
  87 If this is a supplemental package link, inserting it will order the
  88 supplemental packages for any main packages that already exist.
  89
  90 =cut
  91
  92 sub insert {
  93   my $oldAutoCommit = $FS::UID::AutoCommit;
  94   local $FS::UID::AutoCommit = 0;
  95   my $dbh = dbh;
  96
  97   my $self = shift;
  98   my $error = $self->SUPER::insert(@_);
  99   if ( $error ) {
 100     $dbh->rollback if $oldAutoCommit;
 101     return $error if $error;
 102   }
 103
 104   if ( $self->link_type eq 'supp' ) {
 105     # queue this?
 106     my @main_pkgs = qsearch('cust_pkg', {
 107         pkgpart => $self->src_pkgpart,
 108         cancel  => '',
 109     });
 110     foreach my $main_pkg (@main_pkgs) {
 111       # duplicates code in FS::cust_pkg::uncancel, sort of
 112       my $supp_pkg = FS::cust_pkg->new({
 113           'pkgpart'     => $self->dst_pkgpart,
 114           'pkglinknum'  => $self->pkglinknum,
 115           'main_pkgnum' => $main_pkg->pkgnum,
 116           'order_date'  => time,
 117           map { $_ => $main_pkg->get($_) }
 118           qw( custnum locationnum pkgbatch
 119               start_date setup expire adjourn contract_end bill susp
 120               refnum discountnum waive_setup quantity
 121               recur_show_zero setup_show_zero )
 122       });
 123       $error = $supp_pkg->insert;
 124       if ( $error ) {
 125         $dbh->rollback if $oldAutoCommit;
 126         return "$error (ordering new supplemental package to pkg#".$main_pkg->pkgnum.")" if $error;
 127       }
 128     }
 129
 130     return $error if $error;
 131   }
 132
 133   return;
 134 }
 135
 136 =item delete
 137
 138 Delete this record from the database.
 139
 140 If this is a supplemental package link, deleting it will set pkglinknum = null
 141 for any related packages, and set those packages to expire on their next bill
 142 date.
 143
 144 =cut
 145
 146 my $cancel_reason_text = 'Supplemental package removed';
 147 my $cancel_reason_type = 'Cancel Reason';
 148
 149 sub delete {
 150   my $oldAutoCommit = $FS::UID::AutoCommit;
 151   local $FS::UID::AutoCommit = 0;
 152   my $dbh = dbh;
 153
 154   my $self = shift;
 155
 156   if ( $self->link_type eq 'supp' ) {
 157     my $error = $self->remove_linked;
 158     if ( $error ) {
 159       $dbh->rollback if $oldAutoCommit;
 160       return $error;
 161     }
 162   }
 163
 164   my $error = $self->SUPER::delete(@_);
 165   if ( $error ) {
 166     $dbh->rollback if $oldAutoCommit;
 167     return $error;
 168   }
 169   $dbh->commit;
 170   return;
 171 }
 172
 173 sub remove_linked {
 174   my $self = shift;
 175   my $pkglinknum = $self->pkglinknum;
 176   my $error;
 177
 178   # find linked packages
 179   my @pkgs = qsearch('cust_pkg', { pkglinknum => $pkglinknum });
 180   warn "expiring ".scalar(@pkgs).
 181        " linked packages from part_pkg_link #$pkglinknum\n";
 182
 183   my $reason = qsearchs('reason', { reason => $cancel_reason_text });
 184   if (!$reason) {
 185     # upgrade/FS::Setup created this one automatically
 186     my $reason_type = qsearchs('reason_type',
 187                                { type => $cancel_reason_type }
 188       ) or die "default cancel reason type does not exist";
 189
 190     $reason = FS::reason->new({
 191         reason_type => $reason_type->typenum,
 192         reason      => $cancel_reason_text,
 193         disabled    => 'Y',
 194     });
 195     $error = $reason->insert;
 196     if ( $error ) {
 197       return "$error (creating package cancel reason)";
 198     }
 199   }
 200
 201   foreach my $pkg (@pkgs) {
 202     $pkg->set('pkglinknum' => '');
 203     if ( $pkg->get('cancel') ) {
 204       # then just replace it to unlink the package from this object
 205       $error = $pkg->replace;
 206     } else {
 207       $error = $pkg->cancel(
 208         'date'    => $pkg->get('bill'), # cancel on next bill, or else now
 209         'reason'  => $reason->reasonnum,
 210       );
 211     }
 212     if ( $error ) {
 213       return "$error (scheduling package #".$pkg->pkgnum." for expiration)";
 214     }
 215   }
 216 }
 217
 218 =item replace OLD_RECORD
 219
 220 Replaces the OLD_RECORD with this one in the database.  If there is an error,
 221 returns the error, otherwise returns false.
 222
 223 =cut
 224
 225 # the replace method can be inherited from FS::Record
 226
 227 =item check
 228
 229 Checks all fields to make sure this is a valid link.  If there is
 230 an error, returns the error, otherwise returns false.  Called by the insert
 231 and replace methods.
 232
 233 =cut
 234
 235 # the check method should currently be supplied - FS::Record contains some
 236 # data checking routines
 237
 238 sub check {
 239   my $self = shift;
 240
 241   my $error =
 242     $self->ut_numbern('pkglinknum')
 243     || $self->ut_foreign_key('src_pkgpart', 'part_pkg', 'pkgpart')
 244     || $self->ut_foreign_key('dst_pkgpart', 'part_pkg', 'pkgpart')
 245     || $self->ut_enum('link_type', [ 'bill', 'svc', 'supp' ] )
 246     || $self->ut_enum('hidden', [ '', 'Y' ] )
 247   ;
 248   return $error if $error;
 249
 250   if ( $self->link_type eq 'supp' ) {
 251     # some sanity checking
 252     my $src_pkg = $self->src_pkg;
 253     my $dst_pkg = $self->dst_pkg;
 254     if ( $src_pkg->freq eq '0' and $dst_pkg->freq ne '0' ) {
 255       return "One-time charges can't have supplemental packages."
 256     } elsif ( $dst_pkg->freq ne '0' ) {
 257       my $ratio = $dst_pkg->freq / $src_pkg->freq;
 258       if ($ratio != int($ratio)) {
 259         return "Supplemental package period (pkgpart ".$dst_pkg->pkgpart.
 260                ") must be an integer multiple of main package period.";
 261       }
 262     }
 263   }
 264
 265   $self->SUPER::check;
 266 }
 267
 268 =item src_pkg
 269
 270 Returns the source part_pkg object (see L<FS::part_pkg>).
 271
 272 =cut
 273
 274 sub src_pkg {
 275   my $self = shift;
 276   qsearchs('part_pkg', { 'pkgpart' => $self->src_pkgpart } );
 277 }
 278
 279 =item dst_pkg
 280
 281 Returns the source part_pkg object (see L<FS::part_pkg>).
 282
 283 =cut
 284
 285 sub dst_pkg {
 286   my $self = shift;
 287   qsearchs('part_pkg', { 'pkgpart' => $self->dst_pkgpart } );
 288 }
 289
 290 =back
 291
 292 =head1 BUGS
 293
 294 =head1 SEE ALSO
 295
 296 L<FS::Record>, schema.html from the base documentation.
 297
 298 =cut
 299
 300 1;
 301