rt/lib/RT/Record.pm

   1 # BEGIN BPS TAGGED BLOCK {{{
   2 #
   3 # COPYRIGHT:
   4 #
   5 # This software is Copyright (c) 1996-2007 Best Practical Solutions, LLC
   6 #                                          <jesse@bestpractical.com>
   7 #
   8 # (Except where explicitly superseded by other copyright notices)
   9 #
  10 #
  11 # LICENSE:
  12 #
  13 # This work is made available to you under the terms of Version 2 of
  14 # the GNU General Public License. A copy of that license should have
  15 # been provided with this software, but in any event can be snarfed
  16 # from www.gnu.org.
  17 #
  18 # This work is distributed in the hope that it will be useful, but
  19 # WITHOUT ANY WARRANTY; without even the implied warranty of
  20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 # General Public License for more details.
  22 #
  23 # You should have received a copy of the GNU General Public License
  24 # along with this program; if not, write to the Free Software
  25 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  26 # 02110-1301 or visit their web page on the internet at
  27 # http://www.gnu.org/copyleft/gpl.html.
  28 #
  29 #
  30 # CONTRIBUTION SUBMISSION POLICY:
  31 #
  32 # (The following paragraph is not intended to limit the rights granted
  33 # to you to modify and distribute this software under the terms of
  34 # the GNU General Public License and is only of importance to you if
  35 # you choose to contribute your changes and enhancements to the
  36 # community by submitting them to Best Practical Solutions, LLC.)
  37 #
  38 # By intentionally submitting any modifications, corrections or
  39 # derivatives to this work, or any other work intended for use with
  40 # Request Tracker, to Best Practical Solutions, LLC, you confirm that
  41 # you are the copyright holder for those contributions and you grant
  42 # Best Practical Solutions,  LLC a nonexclusive, worldwide, irrevocable,
  43 # royalty-free, perpetual, license to use, copy, create derivative
  44 # works based on those contributions, and sublicense and distribute
  45 # those contributions and any derivatives thereof.
  46 #
  47 # END BPS TAGGED BLOCK }}}
  48 =head1 NAME
  49
  50   RT::Record - Base class for RT record objects
  51
  52 =head1 SYNOPSIS
  53
  54
  55 =head1 DESCRIPTION
  56
  57
  58 =begin testing
  59
  60 ok (require RT::Record);
  61
  62 =end testing
  63
  64 =head1 METHODS
  65
  66 =cut
  67
  68 package RT::Record;
  69
  70 use strict;
  71 use warnings;
  72
  73 our @ISA;
  74 use base qw(RT::Base);
  75
  76 use RT::Date;
  77 use RT::User;
  78 use RT::Attributes;
  79 use DBIx::SearchBuilder::Record::Cachable;
  80 use Encode qw();
  81
  82 our $_TABLE_ATTR = { };
  83
  84
  85 if ( $RT::DontCacheSearchBuilderRecords ) {
  86     push (@ISA, 'DBIx::SearchBuilder::Record');
  87 } else {
  88     push (@ISA, 'DBIx::SearchBuilder::Record::Cachable');
  89
  90 }
  91
  92 # {{{ sub _Init
  93
  94 sub _Init {
  95     my $self = shift;
  96     $self->_BuildTableAttributes unless ($_TABLE_ATTR->{ref($self)});
  97     $self->CurrentUser(@_);
  98 }
  99
 100 # }}}
 101
 102 # {{{ _PrimaryKeys
 103
 104 =head2 _PrimaryKeys
 105
 106 The primary keys for RT classes is 'id'
 107
 108 =cut
 109
 110 sub _PrimaryKeys {
 111     my $self = shift;
 112     return ( ['id'] );
 113 }
 114
 115 # }}}
 116
 117 =head2 Delete
 118
 119 Delete this record object from the database.
 120
 121 =cut
 122
 123 sub Delete {
 124     my $self = shift;
 125     my ($rv) = $self->SUPER::Delete;
 126     if ($rv) {
 127         return ($rv, $self->loc("Object deleted"));
 128     } else {
 129
 130         return(0, $self->loc("Object could not be deleted"))
 131     }
 132 }
 133
 134 =head2 ObjectTypeStr
 135
 136 Returns a string which is this object's type.  The type is the class,
 137 without the "RT::" prefix.
 138
 139 =begin testing
 140
 141 my $ticket = RT::Ticket->new($RT::SystemUser);
 142 my $group = RT::Group->new($RT::SystemUser);
 143 is($ticket->ObjectTypeStr, 'Ticket', "Ticket returns correct typestring");
 144 is($group->ObjectTypeStr, 'Group', "Group returns correct typestring");
 145
 146 =end testing
 147
 148 =cut
 149
 150 sub ObjectTypeStr {
 151     my $self = shift;
 152     if (ref($self) =~ /^.*::(\w+)$/) {
 153         return $self->loc($1);
 154     } else {
 155         return $self->loc(ref($self));
 156     }
 157 }
 158
 159 =head2 Attributes
 160
 161 Return this object's attributes as an RT::Attributes object
 162
 163 =cut
 164
 165 sub Attributes {
 166     my $self = shift;
 167
 168     unless ($self->{'attributes'}) {
 169         $self->{'attributes'} = RT::Attributes->new($self->CurrentUser);
 170        $self->{'attributes'}->LimitToObject($self);
 171     }
 172     return ($self->{'attributes'});
 173
 174 }
 175
 176
 177 =head2 AddAttribute { Name, Description, Content }
 178
 179 Adds a new attribute for this object.
 180
 181 =cut
 182
 183 sub AddAttribute {
 184     my $self = shift;
 185     my %args = ( Name        => undef,
 186                  Description => undef,
 187                  Content     => undef,
 188                  @_ );
 189
 190     my $attr = RT::Attribute->new( $self->CurrentUser );
 191     my ( $id, $msg ) = $attr->Create(
 192                                       Object    => $self,
 193                                       Name        => $args{'Name'},
 194                                       Description => $args{'Description'},
 195                                       Content     => $args{'Content'} );
 196
 197
 198     # XXX TODO: Why won't RedoSearch work here?
 199     $self->Attributes->_DoSearch;
 200
 201     return ($id, $msg);
 202 }
 203
 204
 205 =head2 SetAttribute { Name, Description, Content }
 206
 207 Like AddAttribute, but replaces all existing attributes with the same Name.
 208
 209 =cut
 210
 211 sub SetAttribute {
 212     my $self = shift;
 213     my %args = ( Name        => undef,
 214                  Description => undef,
 215                  Content     => undef,
 216                  @_ );
 217
 218     my @AttributeObjs = $self->Attributes->Named( $args{'Name'} )
 219         or return $self->AddAttribute( %args );
 220
 221     my $AttributeObj = pop( @AttributeObjs );
 222     $_->Delete foreach @AttributeObjs;
 223
 224     $AttributeObj->SetDescription( $args{'Description'} );
 225     $AttributeObj->SetContent( $args{'Content'} );
 226
 227     $self->Attributes->RedoSearch;
 228     return 1;
 229 }
 230
 231 =head2 DeleteAttribute NAME
 232
 233 Deletes all attributes with the matching name for this object.
 234
 235 =cut
 236
 237 sub DeleteAttribute {
 238     my $self = shift;
 239     my $name = shift;
 240     return $self->Attributes->DeleteEntry( Name => $name );
 241 }
 242
 243 =head2 FirstAttribute NAME
 244
 245 Returns the first attribute with the matching name for this object (as an
 246 L<RT::Attribute> object), or C<undef> if no such attributes exist.
 247
 248 Note that if there is more than one attribute with the matching name on the
 249 object, the choice of which one to return is basically arbitrary.  This may be
 250 made well-defined in the future.
 251
 252 =cut
 253
 254 sub FirstAttribute {
 255     my $self = shift;
 256     my $name = shift;
 257     return ($self->Attributes->Named( $name ))[0];
 258 }
 259
 260
 261 # {{{ sub _Handle
 262 sub _Handle {
 263     my $self = shift;
 264     return ($RT::Handle);
 265 }
 266
 267 # }}}
 268
 269 # {{{ sub Create
 270
 271 =head2  Create PARAMHASH
 272
 273 Takes a PARAMHASH of Column -> Value pairs.
 274 If any Column has a Validate$PARAMNAME subroutine defined and the
 275 value provided doesn't pass validation, this routine returns
 276 an error.
 277
 278 If this object's table has any of the following atetributes defined as
 279 'Auto', this routine will automatically fill in their values.
 280
 281 =cut
 282
 283 sub Create {
 284     my $self    = shift;
 285     my %attribs = (@_);
 286     foreach my $key ( keys %attribs ) {
 287         my $method = "Validate$key";
 288         unless ( $self->$method( $attribs{$key} ) ) {
 289             if (wantarray) {
 290                 return ( 0, $self->loc('Invalid value for [_1]', $key) );
 291             }
 292             else {
 293                 return (0);
 294             }
 295         }
 296     }
 297     my $now = RT::Date->new( $self->CurrentUser );
 298     $now->Set( Format => 'unix', Value => time );
 299     $attribs{'Created'} = $now->ISO() if ( $self->_Accessible( 'Created', 'auto' ) && !$attribs{'Created'});
 300
 301     if ($self->_Accessible( 'Creator', 'auto' ) && !$attribs{'Creator'}) {
 302          $attribs{'Creator'} = $self->CurrentUser->id || '0';
 303     }
 304     $attribs{'LastUpdated'} = $now->ISO()
 305       if ( $self->_Accessible( 'LastUpdated', 'auto' ) && !$attribs{'LastUpdated'});
 306
 307     $attribs{'LastUpdatedBy'} = $self->CurrentUser->id || '0'
 308       if ( $self->_Accessible( 'LastUpdatedBy', 'auto' ) && !$attribs{'LastUpdatedBy'});
 309
 310     my $id = $self->SUPER::Create(%attribs);
 311     if ( UNIVERSAL::isa( $id, 'Class::ReturnValue' ) ) {
 312         if ( $id->errno ) {
 313             if (wantarray) {
 314                 return ( 0,
 315                     $self->loc( "Internal Error: [_1]", $id->{error_message} ) );
 316             }
 317             else {
 318                 return (0);
 319             }
 320         }
 321     }
 322     # If the object was created in the database,
 323     # load it up now, so we're sure we get what the database
 324     # has.  Arguably, this should not be necessary, but there
 325     # isn't much we can do about it.
 326
 327    unless ($id) {
 328     if (wantarray) {
 329         return ( $id, $self->loc('Object could not be created') );
 330     }
 331     else {
 332         return ($id);
 333     }
 334
 335    }
 336
 337     if  (UNIVERSAL::isa('errno',$id)) {
 338         exit(0);
 339        warn "It's here!";
 340         return(undef);
 341     }
 342
 343     $self->Load($id) if ($id);
 344
 345
 346
 347     if (wantarray) {
 348         return ( $id, $self->loc('Object created') );
 349     }
 350     else {
 351         return ($id);
 352     }
 353
 354 }
 355
 356 # }}}
 357
 358 # {{{ sub LoadByCols
 359
 360 =head2 LoadByCols
 361
 362 Override DBIx::SearchBuilder::LoadByCols to do case-insensitive loads if the
 363 DB is case sensitive
 364
 365 =cut
 366
 367 sub LoadByCols {
 368     my $self = shift;
 369     my %hash = (@_);
 370
 371     # We don't want to hang onto this
 372     delete $self->{'attributes'};
 373
 374     # If this database is case sensitive we need to uncase objects for
 375     # explicit loading
 376     if ( $self->_Handle->CaseSensitive ) {
 377         my %newhash;
 378         foreach my $key ( keys %hash ) {
 379
 380             # If we've been passed an empty value, we can't do the lookup.
 381             # We don't need to explicitly downcase integers or an id.
 382             if ( $key =~ '^id$'
 383                 || !defined( $hash{$key} )
 384                 || $hash{$key} =~ /^\d+$/
 385                  )
 386             {
 387                 $newhash{$key} = $hash{$key};
 388             }
 389             else {
 390                 my ($op, $val, $func);
 391                 ($key, $op, $val, $func) = $self->_Handle->_MakeClauseCaseInsensitive($key, '=', $hash{$key});
 392                 $newhash{$key}->{operator} = $op;
 393                 $newhash{$key}->{value} = $val;
 394                 $newhash{$key}->{function} = $func;
 395             }
 396         }
 397
 398         # We've clobbered everything we care about. bash the old hash
 399         # and replace it with the new hash
 400         %hash = %newhash;
 401     }
 402     $self->SUPER::LoadByCols(%hash);
 403 }
 404
 405 # }}}
 406
 407 # {{{ Datehandling
 408
 409 # There is room for optimizations in most of those subs:
 410
 411 # {{{ LastUpdatedObj
 412
 413 sub LastUpdatedObj {
 414     my $self = shift;
 415     my $obj  = new RT::Date( $self->CurrentUser );
 416
 417     $obj->Set( Format => 'sql', Value => $self->LastUpdated );
 418     return $obj;
 419 }
 420
 421 # }}}
 422
 423 # {{{ CreatedObj
 424
 425 sub CreatedObj {
 426     my $self = shift;
 427     my $obj  = new RT::Date( $self->CurrentUser );
 428
 429     $obj->Set( Format => 'sql', Value => $self->Created );
 430
 431     return $obj;
 432 }
 433
 434 # }}}
 435
 436 # {{{ AgeAsString
 437 #
 438 # TODO: This should be deprecated
 439 #
 440 sub AgeAsString {
 441     my $self = shift;
 442     return ( $self->CreatedObj->AgeAsString() );
 443 }
 444
 445 # }}}
 446
 447 # {{{ LastUpdatedAsString
 448
 449 # TODO this should be deprecated
 450
 451 sub LastUpdatedAsString {
 452     my $self = shift;
 453     if ( $self->LastUpdated ) {
 454         return ( $self->LastUpdatedObj->AsString() );
 455
 456     }
 457     else {
 458         return "never";
 459     }
 460 }
 461
 462 # }}}
 463
 464 # {{{ CreatedAsString
 465 #
 466 # TODO This should be deprecated
 467 #
 468 sub CreatedAsString {
 469     my $self = shift;
 470     return ( $self->CreatedObj->AsString() );
 471 }
 472
 473 # }}}
 474
 475 # {{{ LongSinceUpdateAsString
 476 #
 477 # TODO This should be deprecated
 478 #
 479 sub LongSinceUpdateAsString {
 480     my $self = shift;
 481     if ( $self->LastUpdated ) {
 482
 483         return ( $self->LastUpdatedObj->AgeAsString() );
 484
 485     }
 486     else {
 487         return "never";
 488     }
 489 }
 490
 491 # }}}
 492
 493 # }}} Datehandling
 494
 495 # {{{ sub _Set
 496 #
 497 sub _Set {
 498     my $self = shift;
 499
 500     my %args = (
 501         Field => undef,
 502         Value => undef,
 503         IsSQL => undef,
 504         @_
 505     );
 506
 507     #if the user is trying to modify the record
 508     # TODO: document _why_ this code is here
 509
 510     if ( ( !defined( $args{'Field'} ) ) || ( !defined( $args{'Value'} ) ) ) {
 511         $args{'Value'} = 0;
 512     }
 513
 514     my $old_val = $self->__Value($args{'Field'});
 515      $self->_SetLastUpdated();
 516     my $ret = $self->SUPER::_Set(
 517         Field => $args{'Field'},
 518         Value => $args{'Value'},
 519         IsSQL => $args{'IsSQL'}
 520     );
 521         my ($status, $msg) =  $ret->as_array();
 522
 523         # @values has two values, a status code and a message.
 524
 525     # $ret is a Class::ReturnValue object. as such, in a boolean context, it's a bool
 526     # we want to change the standard "success" message
 527     if ($status) {
 528         $msg =
 529           $self->loc(
 530             "[_1] changed from [_2] to [_3]",
 531             $args{'Field'},
 532             ( $old_val ? "'$old_val'" : $self->loc("(no value)") ),
 533             '"' . $self->__Value( $args{'Field'}) . '"'
 534           );
 535       } else {
 536
 537           $msg = $self->CurrentUser->loc_fuzzy($msg);
 538     }
 539     return wantarray ? ($status, $msg) : $ret;
 540
 541 }
 542
 543 # }}}
 544
 545 # {{{ sub _SetLastUpdated
 546
 547 =head2 _SetLastUpdated
 548
 549 This routine updates the LastUpdated and LastUpdatedBy columns of the row in question
 550 It takes no options. Arguably, this is a bug
 551
 552 =cut
 553
 554 sub _SetLastUpdated {
 555     my $self = shift;
 556     use RT::Date;
 557     my $now = new RT::Date( $self->CurrentUser );
 558     $now->SetToNow();
 559
 560     if ( $self->_Accessible( 'LastUpdated', 'auto' ) ) {
 561         my ( $msg, $val ) = $self->__Set(
 562             Field => 'LastUpdated',
 563             Value => $now->ISO
 564         );
 565     }
 566     if ( $self->_Accessible( 'LastUpdatedBy', 'auto' ) ) {
 567         my ( $msg, $val ) = $self->__Set(
 568             Field => 'LastUpdatedBy',
 569             Value => $self->CurrentUser->id
 570         );
 571     }
 572 }
 573
 574 # }}}
 575
 576 # {{{ sub CreatorObj
 577
 578 =head2 CreatorObj
 579
 580 Returns an RT::User object with the RT account of the creator of this row
 581
 582 =cut
 583
 584 sub CreatorObj {
 585     my $self = shift;
 586     unless ( exists $self->{'CreatorObj'} ) {
 587
 588         $self->{'CreatorObj'} = RT::User->new( $self->CurrentUser );
 589         $self->{'CreatorObj'}->Load( $self->Creator );
 590     }
 591     return ( $self->{'CreatorObj'} );
 592 }
 593
 594 # }}}
 595
 596 # {{{ sub LastUpdatedByObj
 597
 598 =head2 LastUpdatedByObj
 599
 600   Returns an RT::User object of the last user to touch this object
 601
 602 =cut
 603
 604 sub LastUpdatedByObj {
 605     my $self = shift;
 606     unless ( exists $self->{LastUpdatedByObj} ) {
 607         $self->{'LastUpdatedByObj'} = RT::User->new( $self->CurrentUser );
 608         $self->{'LastUpdatedByObj'}->Load( $self->LastUpdatedBy );
 609     }
 610     return $self->{'LastUpdatedByObj'};
 611 }
 612
 613 # }}}
 614
 615 # {{{ sub URI
 616
 617 =head2 URI
 618
 619 Returns this record's URI
 620
 621 =cut
 622
 623 sub URI {
 624     my $self = shift;
 625     my $uri = RT::URI::fsck_com_rt->new($self->CurrentUser);
 626     return($uri->URIForObject($self));
 627 }
 628
 629 # }}}
 630
 631 =head2 ValidateName NAME
 632
 633 Validate the name of the record we're creating. Mostly, just make sure it's not a numeric ID, which is invalid for Name
 634
 635 =cut
 636
 637 sub ValidateName {
 638     my $self = shift;
 639     my $value = shift;
 640     if ($value && $value=~ /^\d+$/) {
 641         return(0);
 642     } else  {
 643          return (1);
 644     }
 645 }
 646
 647
 648
 649 =head2 SQLType attribute
 650
 651 return the SQL type for the attribute 'attribute' as stored in _ClassAccessible
 652
 653 =cut
 654
 655 sub SQLType {
 656     my $self = shift;
 657     my $field = shift;
 658
 659     return ($self->_Accessible($field, 'type'));
 660
 661
 662 }
 663
 664
 665 sub __Value {
 666     my $self  = shift;
 667     my $field = shift;
 668     my %args = ( decode_utf8 => 1,
 669                  @_ );
 670
 671     unless (defined $field && $field) {
 672         $RT::Logger->error("$self __Value called with undef field");
 673     }
 674     my $value = $self->SUPER::__Value($field);
 675
 676     return('') if ( !defined($value) || $value eq '');
 677
 678     if( $args{'decode_utf8'} ) {
 679         # XXX: is_utf8 check should be here unless Encode bug would be fixed
 680         # see http://rt.cpan.org/NoAuth/Bug.html?id=14559
 681         return Encode::decode_utf8($value) unless Encode::is_utf8($value);
 682     } else {
 683         # check is_utf8 here just to be shure
 684         return Encode::encode_utf8($value) if Encode::is_utf8($value);
 685     }
 686     return $value;
 687 }
 688
 689 # Set up defaults for DBIx::SearchBuilder::Record::Cachable
 690
 691 sub _CacheConfig {
 692   {
 693      'cache_p'        => 1,
 694      'cache_for_sec'  => 30,
 695   }
 696 }
 697
 698
 699
 700 sub _BuildTableAttributes {
 701     my $self = shift;
 702
 703     my $attributes;
 704     if ( UNIVERSAL::can( $self, '_CoreAccessible' ) ) {
 705        $attributes = $self->_CoreAccessible();
 706     } elsif ( UNIVERSAL::can( $self, '_ClassAccessible' ) ) {
 707        $attributes = $self->_ClassAccessible();
 708
 709     }
 710
 711     foreach my $column (%$attributes) {
 712         foreach my $attr ( %{ $attributes->{$column} } ) {
 713             $_TABLE_ATTR->{ref($self)}->{$column}->{$attr} = $attributes->{$column}->{$attr};
 714         }
 715     }
 716     if ( UNIVERSAL::can( $self, '_OverlayAccessible' ) ) {
 717         $attributes = $self->_OverlayAccessible();
 718
 719         foreach my $column (%$attributes) {
 720             foreach my $attr ( %{ $attributes->{$column} } ) {
 721                 $_TABLE_ATTR->{ref($self)}->{$column}->{$attr} = $attributes->{$column}->{$attr};
 722             }
 723         }
 724     }
 725     if ( UNIVERSAL::can( $self, '_VendorAccessible' ) ) {
 726         $attributes = $self->_VendorAccessible();
 727
 728         foreach my $column (%$attributes) {
 729             foreach my $attr ( %{ $attributes->{$column} } ) {
 730                 $_TABLE_ATTR->{ref($self)}->{$column}->{$attr} = $attributes->{$column}->{$attr};
 731             }
 732         }
 733     }
 734     if ( UNIVERSAL::can( $self, '_LocalAccessible' ) ) {
 735         $attributes = $self->_LocalAccessible();
 736
 737         foreach my $column (%$attributes) {
 738             foreach my $attr ( %{ $attributes->{$column} } ) {
 739                 $_TABLE_ATTR->{ref($self)}->{$column}->{$attr} = $attributes->{$column}->{$attr};
 740             }
 741         }
 742     }
 743
 744 }
 745
 746
 747 =head2 _ClassAccessible
 748
 749 Overrides the "core" _ClassAccessible using $_TABLE_ATTR. Behaves identical to the version in
 750 DBIx::SearchBuilder::Record
 751
 752 =cut
 753
 754 sub _ClassAccessible {
 755     my $self = shift;
 756     return $_TABLE_ATTR->{ref($self)};
 757 }
 758
 759 =head2 _Accessible COLUMN ATTRIBUTE
 760
 761 returns the value of ATTRIBUTE for COLUMN
 762
 763
 764 =cut
 765
 766 sub _Accessible  {
 767   my $self = shift;
 768   my $column = shift;
 769   my $attribute = lc(shift);
 770   return 0 unless defined ($_TABLE_ATTR->{ref($self)}->{$column});
 771   return $_TABLE_ATTR->{ref($self)}->{$column}->{$attribute} || 0;
 772
 773 }
 774
 775 =head2 _EncodeLOB BODY MIME_TYPE
 776
 777 Takes a potentially large attachment. Returns (ContentEncoding, EncodedBody) based on system configuration and selected database
 778
 779 =cut
 780
 781 sub _EncodeLOB {
 782         my $self = shift;
 783         my $Body = shift;
 784         my $MIMEType = shift;
 785
 786         my $ContentEncoding = 'none';
 787
 788         #get the max attachment length from RT
 789         my $MaxSize = $RT::MaxAttachmentSize;
 790
 791         #if the current attachment contains nulls and the
 792         #database doesn't support embedded nulls
 793
 794         if ( $RT::AlwaysUseBase64 or
 795              ( !$RT::Handle->BinarySafeBLOBs ) && ( $Body =~ /\x00/ ) ) {
 796
 797             # set a flag telling us to mimencode the attachment
 798             $ContentEncoding = 'base64';
 799
 800             #cut the max attchment size by 25% (for mime-encoding overhead.
 801             $RT::Logger->debug("Max size is $MaxSize\n");
 802             $MaxSize = $MaxSize * 3 / 4;
 803         # Some databases (postgres) can't handle non-utf8 data
 804         } elsif (    !$RT::Handle->BinarySafeBLOBs
 805                   && $MIMEType !~ /text\/plain/gi
 806                   && !Encode::is_utf8( $Body, 1 ) ) {
 807               $ContentEncoding = 'quoted-printable';
 808         }
 809
 810         #if the attachment is larger than the maximum size
 811         if ( ($MaxSize) and ( $MaxSize < length($Body) ) ) {
 812
 813             # if we're supposed to truncate large attachments
 814             if ($RT::TruncateLongAttachments) {
 815
 816                 # truncate the attachment to that length.
 817                 $Body = substr( $Body, 0, $MaxSize );
 818
 819             }
 820
 821             # elsif we're supposed to drop large attachments on the floor,
 822             elsif ($RT::DropLongAttachments) {
 823
 824                 # drop the attachment on the floor
 825                 $RT::Logger->info( "$self: Dropped an attachment of size "
 826                                    . length($Body) . "\n"
 827                                    . "It started: " . substr( $Body, 0, 60 ) . "\n"
 828                                  );
 829                 return ("none", "Large attachment dropped" );
 830             }
 831         }
 832
 833         # if we need to mimencode the attachment
 834         if ( $ContentEncoding eq 'base64' ) {
 835
 836             # base64 encode the attachment
 837             Encode::_utf8_off($Body);
 838             $Body = MIME::Base64::encode_base64($Body);
 839
 840         } elsif ($ContentEncoding eq 'quoted-printable') {
 841             Encode::_utf8_off($Body);
 842             $Body = MIME::QuotedPrint::encode($Body);
 843         }
 844
 845
 846         return ($ContentEncoding, $Body);
 847
 848 }
 849
 850 sub _DecodeLOB {
 851     my $self            = shift;
 852     my $ContentType     = shift;
 853     my $ContentEncoding = shift;
 854     my $Content         = shift;
 855
 856     if ( $ContentEncoding eq 'base64' ) {
 857         $Content = MIME::Base64::decode_base64($Content);
 858     }
 859     elsif ( $ContentEncoding eq 'quoted-printable' ) {
 860         $Content = MIME::QuotedPrint::decode($Content);
 861     }
 862     elsif ( $ContentEncoding && $ContentEncoding ne 'none' ) {
 863         return ( $self->loc( "Unknown ContentEncoding [_1]", $ContentEncoding ) );
 864     }
 865     if ( RT::I18N::IsTextualContentType($ContentType) ) {
 866        $Content = Encode::decode_utf8($Content) unless Encode::is_utf8($Content);
 867     }
 868         return ($Content);
 869 }
 870
 871 # {{{ LINKDIRMAP
 872 # A helper table for links mapping to make it easier
 873 # to build and parse links between tickets
 874
 875 use vars '%LINKDIRMAP';
 876
 877 %LINKDIRMAP = (
 878     MemberOf => { Base => 'MemberOf',
 879                   Target => 'HasMember', },
 880     RefersTo => { Base => 'RefersTo',
 881                 Target => 'ReferredToBy', },
 882     DependsOn => { Base => 'DependsOn',
 883                    Target => 'DependedOnBy', },
 884     MergedInto => { Base => 'MergedInto',
 885                    Target => 'MergedInto', },
 886
 887 );
 888
 889 =head2 Update  ARGSHASH
 890
 891 Updates fields on an object for you using the proper Set methods,
 892 skipping unchanged values.
 893
 894  ARGSRef => a hashref of attributes => value for the update
 895  AttributesRef => an arrayref of keys in ARGSRef that should be updated
 896  AttributePrefix => a prefix that should be added to the attributes in AttributesRef
 897                     when looking up values in ARGSRef
 898                     Bare attributes are tried before prefixed attributes
 899
 900 Returns a list of localized results of the update
 901
 902 =cut
 903
 904 sub Update {
 905     my $self = shift;
 906
 907     my %args = (
 908         ARGSRef         => undef,
 909         AttributesRef   => undef,
 910         AttributePrefix => undef,
 911         @_
 912     );
 913
 914     my $attributes = $args{'AttributesRef'};
 915     my $ARGSRef    = $args{'ARGSRef'};
 916     my @results;
 917
 918     foreach my $attribute (@$attributes) {
 919         my $value;
 920         if ( defined $ARGSRef->{$attribute} ) {
 921             $value = $ARGSRef->{$attribute};
 922         }
 923         elsif (
 924             defined( $args{'AttributePrefix'} )
 925             && defined(
 926                 $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute }
 927             )
 928           ) {
 929             $value = $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute };
 930
 931         }
 932         else {
 933             next;
 934         }
 935
 936         $value =~ s/\r\n/\n/gs;
 937
 938
 939         # If Queue is 'General', we want to resolve the queue name for
 940         # the object.
 941
 942         # This is in an eval block because $object might not exist.
 943         # and might not have a Name method. But "can" won't find autoloaded
 944         # items. If it fails, we don't care
 945         eval {
 946             my $object = $attribute . "Obj";
 947             next if ($self->$object->Name eq $value);
 948         };
 949         next if ( $value eq $self->$attribute() );
 950         my $method = "Set$attribute";
 951         my ( $code, $msg ) = $self->$method($value);
 952         my ($prefix) = ref($self) =~ /RT(?:.*)::(\w+)/;
 953
 954         # Default to $id, but use name if we can get it.
 955         my $label = $self->id;
 956         $label = $self->Name if (UNIVERSAL::can($self,'Name'));
 957         push @results, $self->loc( "$prefix [_1]", $label ) . ': '. $msg;
 958
 959 =for loc
 960
 961                                    "[_1] could not be set to [_2].",       # loc
 962                                    "That is already the current value",    # loc
 963                                    "No value sent to _Set!\n",             # loc
 964                                    "Illegal value for [_1]",               # loc
 965                                    "The new value has been set.",          # loc
 966                                    "No column specified",                  # loc
 967                                    "Immutable field",                      # loc
 968                                    "Nonexistant field?",                   # loc
 969                                    "Invalid data",                         # loc
 970                                    "Couldn't find row",                    # loc
 971                                    "Missing a primary key?: [_1]",         # loc
 972                                    "Found Object",                         # loc
 973
 974 =cut
 975
 976     }
 977
 978     return @results;
 979 }
 980
 981 # {{{ Routines dealing with Links
 982
 983 # {{{ Link Collections
 984
 985 # {{{ sub Members
 986
 987 =head2 Members
 988
 989   This returns an RT::Links object which references all the tickets
 990 which are 'MembersOf' this ticket
 991
 992 =cut
 993
 994 sub Members {
 995     my $self = shift;
 996     return ( $self->_Links( 'Target', 'MemberOf' ) );
 997 }
 998
 999 # }}}
1000
1001 # {{{ sub MemberOf
1002
1003 =head2 MemberOf
1004
1005   This returns an RT::Links object which references all the tickets that this
1006 ticket is a 'MemberOf'
1007
1008 =cut
1009
1010 sub MemberOf {
1011     my $self = shift;
1012     return ( $self->_Links( 'Base', 'MemberOf' ) );
1013 }
1014
1015 # }}}
1016
1017 # {{{ RefersTo
1018
1019 =head2 RefersTo
1020
1021   This returns an RT::Links object which shows all references for which this ticket is a base
1022
1023 =cut
1024
1025 sub RefersTo {
1026     my $self = shift;
1027     return ( $self->_Links( 'Base', 'RefersTo' ) );
1028 }
1029
1030 # }}}
1031
1032 # {{{ ReferredToBy
1033
1034 =head2 ReferredToBy
1035
1036 This returns an L<RT::Links> object which shows all references for which this ticket is a target
1037
1038 =cut
1039
1040 sub ReferredToBy {
1041     my $self = shift;
1042     return ( $self->_Links( 'Target', 'RefersTo' ) );
1043 }
1044
1045 # }}}
1046
1047 # {{{ DependedOnBy
1048
1049 =head2 DependedOnBy
1050
1051   This returns an RT::Links object which references all the tickets that depend on this one
1052
1053 =cut
1054
1055 sub DependedOnBy {
1056     my $self = shift;
1057     return ( $self->_Links( 'Target', 'DependsOn' ) );
1058 }
1059
1060 # }}}
1061
1062
1063
1064 =head2 HasUnresolvedDependencies
1065
1066   Takes a paramhash of Type (default to '__any').  Returns true if
1067 $self->UnresolvedDependencies returns an object with one or more members
1068 of that type.  Returns false otherwise
1069
1070
1071 =begin testing
1072
1073 my $t1 = RT::Ticket->new($RT::SystemUser);
1074 my ($id, $trans, $msg) = $t1->Create(Subject => 'DepTest1', Queue => 'general');
1075 ok($id, "Created dep test 1 - $msg");
1076
1077 my $t2 = RT::Ticket->new($RT::SystemUser);
1078 my ($id2, $trans, $msg2) = $t2->Create(Subject => 'DepTest2', Queue => 'general');
1079 ok($id2, "Created dep test 2 - $msg2");
1080 my $t3 = RT::Ticket->new($RT::SystemUser);
1081 my ($id3, $trans, $msg3) = $t3->Create(Subject => 'DepTest3', Queue => 'general', Type => 'approval');
1082 ok($id3, "Created dep test 3 - $msg3");
1083 my ($addid, $addmsg);
1084 ok (($addid, $addmsg) =$t1->AddLink( Type => 'DependsOn', Target => $t2->id));
1085 ok ($addid, $addmsg);
1086 ok (($addid, $addmsg) =$t1->AddLink( Type => 'DependsOn', Target => $t3->id));
1087
1088 ok ($addid, $addmsg);
1089 my $link = RT::Link->new($RT::SystemUser);
1090 my ($rv, $msg) = $link->Load($addid);
1091 ok ($rv, $msg);
1092 ok ($link->LocalTarget == $t3->id, "Link LocalTarget is correct");
1093 ok ($link->LocalBase   == $t1->id, "Link LocalBase   is correct");
1094
1095 ok ($t1->HasUnresolvedDependencies, "Ticket ".$t1->Id." has unresolved deps");
1096 ok (!$t1->HasUnresolvedDependencies( Type => 'blah' ), "Ticket ".$t1->Id." has no unresolved blahs");
1097 ok ($t1->HasUnresolvedDependencies( Type => 'approval' ), "Ticket ".$t1->Id." has unresolved approvals");
1098 ok (!$t2->HasUnresolvedDependencies, "Ticket ".$t2->Id." has no unresolved deps");
1099 ;
1100
1101 my ($rid, $rmsg)= $t1->Resolve();
1102 ok(!$rid, $rmsg);
1103 my ($rid2, $rmsg2) = $t2->Resolve();
1104 ok ($rid2, $rmsg2);
1105 ($rid, $rmsg)= $t1->Resolve();
1106 ok(!$rid, $rmsg);
1107 my ($rid3,$rmsg3) = $t3->Resolve;
1108 ok ($rid3,$rmsg3);
1109 ($rid, $rmsg)= $t1->Resolve();
1110 ok($rid, $rmsg);
1111
1112
1113 =end testing
1114
1115 =cut
1116
1117 sub HasUnresolvedDependencies {
1118     my $self = shift;
1119     my %args = (
1120         Type   => undef,
1121         @_
1122     );
1123
1124     my $deps = $self->UnresolvedDependencies;
1125
1126     if ($args{Type}) {
1127         $deps->Limit( FIELD => 'Type',
1128               OPERATOR => '=',
1129               VALUE => $args{Type});
1130     }
1131     else {
1132             $deps->IgnoreType;
1133     }
1134
1135     if ($deps->Count > 0) {
1136         return 1;
1137     }
1138     else {
1139         return (undef);
1140     }
1141 }
1142
1143
1144 # {{{ UnresolvedDependencies
1145
1146 =head2 UnresolvedDependencies
1147
1148 Returns an RT::Tickets object of tickets which this ticket depends on
1149 and which have a status of new, open or stalled. (That list comes from
1150 RT::Queue->ActiveStatusArray
1151
1152 =cut
1153
1154
1155 sub UnresolvedDependencies {
1156     my $self = shift;
1157     my $deps = RT::Tickets->new($self->CurrentUser);
1158
1159     my @live_statuses = RT::Queue->ActiveStatusArray();
1160     foreach my $status (@live_statuses) {
1161         $deps->LimitStatus(VALUE => $status);
1162     }
1163     $deps->LimitDependedOnBy($self->Id);
1164
1165     return($deps);
1166
1167 }
1168
1169 # }}}
1170
1171 # {{{ AllDependedOnBy
1172
1173 =head2 AllDependedOnBy
1174
1175 Returns an array of RT::Ticket objects which (directly or indirectly)
1176 depends on this ticket; takes an optional 'Type' argument in the param
1177 hash, which will limit returned tickets to that type, as well as cause
1178 tickets with that type to serve as 'leaf' nodes that stops the recursive
1179 dependency search.
1180
1181 =cut
1182
1183 sub AllDependedOnBy {
1184     my $self = shift;
1185     my $dep = $self->DependedOnBy;
1186     my %args = (
1187         Type   => undef,
1188         _found => {},
1189         _top   => 1,
1190         @_
1191     );
1192
1193     while (my $link = $dep->Next()) {
1194         next unless ($link->BaseURI->IsLocal());
1195         next if $args{_found}{$link->BaseObj->Id};
1196
1197         if (!$args{Type}) {
1198             $args{_found}{$link->BaseObj->Id} = $link->BaseObj;
1199             $link->BaseObj->AllDependedOnBy( %args, _top => 0 );
1200         }
1201         elsif ($link->BaseObj->Type eq $args{Type}) {
1202             $args{_found}{$link->BaseObj->Id} = $link->BaseObj;
1203         }
1204         else {
1205             $link->BaseObj->AllDependedOnBy( %args, _top => 0 );
1206         }
1207     }
1208
1209     if ($args{_top}) {
1210         return map { $args{_found}{$_} } sort keys %{$args{_found}};
1211     }
1212     else {
1213         return 1;
1214     }
1215 }
1216
1217 # }}}
1218
1219 # {{{ DependsOn
1220
1221 =head2 DependsOn
1222
1223   This returns an RT::Links object which references all the tickets that this ticket depends on
1224
1225 =cut
1226
1227 sub DependsOn {
1228     my $self = shift;
1229     return ( $self->_Links( 'Base', 'DependsOn' ) );
1230 }
1231
1232 # }}}
1233
1234 # {{{ Customers
1235
1236 =head2 Customers
1237
1238   This returns an RT::Links object which references all the customers that this object is a member of.
1239
1240 =cut
1241
1242 sub Customers {
1243     my( $self, %opt ) = @_;
1244     my $Debug = $opt{'Debug'};
1245
1246     unless ( $self->{'Customers'} ) {
1247
1248       $self->{'Customers'} = $self->MemberOf->Clone;
1249
1250       $self->{'Customers'}->Limit(
1251                                    FIELD    => 'Target',
1252                                    OPERATOR => 'STARTSWITH',
1253                                    VALUE    => 'freeside://freeside/cust_main/',
1254                                  );
1255     }
1256
1257     warn "->Customers method called on $self; returning ".
1258          ref($self->{'Customers'}). ' object'
1259       if $Debug;
1260
1261     return $self->{'Customers'};
1262 }
1263
1264 # }}}
1265
1266 # {{{ sub _Links
1267
1268 =head2 Links DIRECTION [TYPE]
1269
1270 Return links (L<RT::Links>) to/from this object.
1271
1272 DIRECTION is either 'Base' or 'Target'.
1273
1274 TYPE is a type of links to return, it can be omitted to get
1275 links of any type.
1276
1277 =cut
1278
1279 *Links = \&_Links;
1280
1281 sub _Links {
1282     my $self = shift;
1283
1284     #TODO: Field isn't the right thing here. but I ahave no idea what mnemonic ---
1285     #tobias meant by $f
1286     my $field = shift;
1287     my $type  = shift || "";
1288
1289     unless ( $self->{"$field$type"} ) {
1290         $self->{"$field$type"} = new RT::Links( $self->CurrentUser );
1291             # at least to myself
1292             $self->{"$field$type"}->Limit( FIELD => $field,
1293                                            VALUE => $self->URI,
1294                                            ENTRYAGGREGATOR => 'OR' );
1295             $self->{"$field$type"}->Limit( FIELD => 'Type',
1296                                            VALUE => $type )
1297               if ($type);
1298     }
1299     return ( $self->{"$field$type"} );
1300 }
1301
1302 # }}}
1303
1304 # }}}
1305
1306 # {{{ sub _AddLink
1307
1308 =head2 _AddLink
1309
1310 Takes a paramhash of Type and one of Base or Target. Adds that link to this object.
1311
1312 Returns C<link id>, C<message> and C<exist> flag.
1313
1314
1315 =cut
1316
1317
1318 sub _AddLink {
1319     my $self = shift;
1320     my %args = ( Target => '',
1321                  Base   => '',
1322                  Type   => '',
1323                  Silent => undef,
1324                  @_ );
1325
1326
1327     # Remote_link is the URI of the object that is not this ticket
1328     my $remote_link;
1329     my $direction;
1330
1331     if ( $args{'Base'} and $args{'Target'} ) {
1332         $RT::Logger->debug( "$self tried to create a link. both base and target were specified\n" );
1333         return ( 0, $self->loc("Can't specifiy both base and target") );
1334     }
1335     elsif ( $args{'Base'} ) {
1336         $args{'Target'} = $self->URI();
1337         $remote_link    = $args{'Base'};
1338         $direction      = 'Target';
1339     }
1340     elsif ( $args{'Target'} ) {
1341         $args{'Base'} = $self->URI();
1342         $remote_link  = $args{'Target'};
1343         $direction    = 'Base';
1344     }
1345     else {
1346         return ( 0, $self->loc('Either base or target must be specified') );
1347     }
1348
1349     # {{{ Check if the link already exists - we don't want duplicates
1350     use RT::Link;
1351     my $old_link = RT::Link->new( $self->CurrentUser );
1352     $old_link->LoadByParams( Base   => $args{'Base'},
1353                              Type   => $args{'Type'},
1354                              Target => $args{'Target'} );
1355     if ( $old_link->Id ) {
1356         $RT::Logger->debug("$self Somebody tried to duplicate a link");
1357         return ( $old_link->id, $self->loc("Link already exists"), 1 );
1358     }
1359
1360     # }}}
1361
1362
1363     # Storing the link in the DB.
1364     my $link = RT::Link->new( $self->CurrentUser );
1365     my ($linkid, $linkmsg) = $link->Create( Target => $args{Target},
1366                                   Base   => $args{Base},
1367                                   Type   => $args{Type} );
1368
1369     unless ($linkid) {
1370         $RT::Logger->error("Link could not be created: ".$linkmsg);
1371         return ( 0, $self->loc("Link could not be created") );
1372     }
1373
1374     my $TransString =
1375       "Record $args{'Base'} $args{Type} record $args{'Target'}.";
1376
1377     return ( $linkid, $self->loc( "Link created ([_1])", $TransString ) );
1378 }
1379
1380 # }}}
1381
1382 # {{{ sub _DeleteLink
1383
1384 =head2 _DeleteLink
1385
1386 Delete a link. takes a paramhash of Base, Target and Type.
1387 Either Base or Target must be null. The null value will
1388 be replaced with this ticket\'s id
1389
1390 =cut
1391
1392 sub _DeleteLink {
1393     my $self = shift;
1394     my %args = (
1395         Base   => undef,
1396         Target => undef,
1397         Type   => undef,
1398         @_
1399     );
1400
1401     #we want one of base and target. we don't care which
1402     #but we only want _one_
1403
1404     my $direction;
1405     my $remote_link;
1406
1407     if ( $args{'Base'} and $args{'Target'} ) {
1408         $RT::Logger->debug("$self ->_DeleteLink. got both Base and Target\n");
1409         return ( 0, $self->loc("Can't specifiy both base and target") );
1410     }
1411     elsif ( $args{'Base'} ) {
1412         $args{'Target'} = $self->URI();
1413         $remote_link = $args{'Base'};
1414         $direction = 'Target';
1415     }
1416     elsif ( $args{'Target'} ) {
1417         $args{'Base'} = $self->URI();
1418         $remote_link = $args{'Target'};
1419         $direction='Base';
1420     }
1421     else {
1422         $RT::Logger->error("Base or Target must be specified\n");
1423         return ( 0, $self->loc('Either base or target must be specified') );
1424     }
1425
1426     my $link = new RT::Link( $self->CurrentUser );
1427     $RT::Logger->debug( "Trying to load link: " . $args{'Base'} . " " . $args{'Type'} . " " . $args{'Target'} . "\n" );
1428
1429
1430     $link->LoadByParams( Base=> $args{'Base'}, Type=> $args{'Type'}, Target=>  $args{'Target'} );
1431     #it's a real link.
1432     if ( $link->id ) {
1433
1434         my $linkid = $link->id;
1435         $link->Delete();
1436
1437         my $TransString = "Record $args{'Base'} no longer $args{Type} record $args{'Target'}.";
1438         return ( 1, $self->loc("Link deleted ([_1])", $TransString));
1439     }
1440
1441     #if it's not a link we can find
1442     else {
1443         $RT::Logger->debug("Couldn't find that link\n");
1444         return ( 0, $self->loc("Link not found") );
1445     }
1446 }
1447
1448 # }}}
1449
1450 # }}}
1451
1452 # {{{ Routines dealing with transactions
1453
1454 # {{{ sub _NewTransaction
1455
1456 =head2 _NewTransaction  PARAMHASH
1457
1458 Private function to create a new RT::Transaction object for this ticket update
1459
1460 =cut
1461
1462 sub _NewTransaction {
1463     my $self = shift;
1464     my %args = (
1465         TimeTaken => undef,
1466         Type      => undef,
1467         OldValue  => undef,
1468         NewValue  => undef,
1469         OldReference  => undef,
1470         NewReference  => undef,
1471         ReferenceType => undef,
1472         Data      => undef,
1473         Field     => undef,
1474         MIMEObj   => undef,
1475         ActivateScrips => 1,
1476         CommitScrips => 1,
1477         @_
1478     );
1479
1480     my $old_ref = $args{'OldReference'};
1481     my $new_ref = $args{'NewReference'};
1482     my $ref_type = $args{'ReferenceType'};
1483     if ($old_ref or $new_ref) {
1484         $ref_type ||= ref($old_ref) || ref($new_ref);
1485         if (!$ref_type) {
1486             $RT::Logger->error("Reference type not specified for transaction");
1487             return;
1488         }
1489         $old_ref = $old_ref->Id if ref($old_ref);
1490         $new_ref = $new_ref->Id if ref($new_ref);
1491     }
1492
1493     require RT::Transaction;
1494     my $trans = new RT::Transaction( $self->CurrentUser );
1495     my ( $transaction, $msg ) = $trans->Create(
1496         ObjectId  => $self->Id,
1497         ObjectType => ref($self),
1498         TimeTaken => $args{'TimeTaken'},
1499         Type      => $args{'Type'},
1500         Data      => $args{'Data'},
1501         Field     => $args{'Field'},
1502         NewValue  => $args{'NewValue'},
1503         OldValue  => $args{'OldValue'},
1504         NewReference  => $new_ref,
1505         OldReference  => $old_ref,
1506         ReferenceType => $ref_type,
1507         MIMEObj   => $args{'MIMEObj'},
1508         ActivateScrips => $args{'ActivateScrips'},
1509         CommitScrips => $args{'CommitScrips'},
1510     );
1511
1512     # Rationalize the object since we may have done things to it during the caching.
1513     $self->Load($self->Id);
1514
1515     $RT::Logger->warning($msg) unless $transaction;
1516
1517     $self->_SetLastUpdated;
1518
1519     if ( defined $args{'TimeTaken'} and $self->can('_UpdateTimeTaken')) {
1520         $self->_UpdateTimeTaken( $args{'TimeTaken'} );
1521     }
1522     if ( $RT::UseTransactionBatch and $transaction ) {
1523             push @{$self->{_TransactionBatch}}, $trans if $args{'CommitScrips'};
1524     }
1525     return ( $transaction, $msg, $trans );
1526 }
1527
1528 # }}}
1529
1530 # {{{ sub Transactions
1531
1532 =head2 Transactions
1533
1534   Returns an RT::Transactions object of all transactions on this record object
1535
1536 =cut
1537
1538 sub Transactions {
1539     my $self = shift;
1540
1541     use RT::Transactions;
1542     my $transactions = RT::Transactions->new( $self->CurrentUser );
1543
1544     #If the user has no rights, return an empty object
1545     $transactions->Limit(
1546         FIELD => 'ObjectId',
1547         VALUE => $self->id,
1548     );
1549     $transactions->Limit(
1550         FIELD => 'ObjectType',
1551         VALUE => ref($self),
1552     );
1553
1554     return ($transactions);
1555 }
1556
1557 # }}}
1558 # }}}
1559 #
1560 # {{{ Routines dealing with custom fields
1561
1562 sub CustomFields {
1563     my $self = shift;
1564     my $cfs  = RT::CustomFields->new( $self->CurrentUser );
1565
1566     # XXX handle multiple types properly
1567     $cfs->LimitToLookupType( $self->CustomFieldLookupType );
1568     $cfs->LimitToGlobalOrObjectId(
1569         $self->_LookupId( $self->CustomFieldLookupType ) );
1570
1571     return $cfs;
1572 }
1573
1574 # TODO: This _only_ works for RT::Class classes. it doesn't work, for example, for RT::FM classes.
1575
1576 sub _LookupId {
1577     my $self = shift;
1578     my $lookup = shift;
1579     my @classes = ($lookup =~ /RT::(\w+)-/g);
1580
1581     my $object = $self;
1582     foreach my $class (reverse @classes) {
1583         my $method = "${class}Obj";
1584         $object = $object->$method;
1585     }
1586
1587     return $object->Id;
1588 }
1589
1590
1591 =head2 CustomFieldLookupType
1592
1593 Returns the path RT uses to figure out which custom fields apply to this object.
1594
1595 =cut
1596
1597 sub CustomFieldLookupType {
1598     my $self = shift;
1599     return ref($self);
1600 }
1601
1602 #TODO Deprecated API. Destroy in 3.6
1603 sub _LookupTypes {
1604     my  $self = shift;
1605     $RT::Logger->warning("_LookupTypes call is deprecated at (". join(":",caller)."). Replace with CustomFieldLookupType");
1606
1607     return($self->CustomFieldLookupType);
1608
1609 }
1610
1611 # {{{ AddCustomFieldValue
1612
1613 =head2 AddCustomFieldValue { Field => FIELD, Value => VALUE }
1614
1615 VALUE should be a string.
1616 FIELD can be a CustomField object OR a CustomField ID.
1617
1618
1619 Adds VALUE as a value of CustomField FIELD.  If this is a single-value custom field,
1620 deletes the old value.
1621 If VALUE is not a valid value for the custom field, returns
1622 (0, 'Error message' ) otherwise, returns (1, 'Success Message')
1623
1624 =cut
1625
1626 sub AddCustomFieldValue {
1627     my $self = shift;
1628     $self->_AddCustomFieldValue(@_);
1629 }
1630
1631 sub _AddCustomFieldValue {
1632     my $self = shift;
1633     my %args = (
1634         Field             => undef,
1635         Value             => undef,
1636         RecordTransaction => 1,
1637         @_
1638     );
1639
1640     my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
1641
1642     unless ( $cf->Id ) {
1643         return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
1644     }
1645
1646     my $OCFs = $self->CustomFields;
1647     $OCFs->Limit( FIELD => 'id', VALUE => $cf->Id );
1648     unless ( $OCFs->Count ) {
1649         return (
1650             0,
1651             $self->loc(
1652                 "Custom field [_1] does not apply to this object",
1653                 $args{'Field'}
1654             )
1655         );
1656     }
1657     # Load up a ObjectCustomFieldValues object for this custom field and this ticket
1658     my $values = $cf->ValuesForObject($self);
1659
1660     unless ( $cf->ValidateValue( $args{'Value'} ) ) {
1661         return ( 0, $self->loc("Invalid value for custom field") );
1662     }
1663
1664     # If the custom field only accepts a certain # of values, delete the existing
1665     # value and record a "changed from foo to bar" transaction
1666     unless ( $cf->UnlimitedValues) {
1667
1668  # We need to whack any old values here.  In most cases, the custom field should
1669  # only have one value to delete.  In the pathalogical case, this custom field
1670  # used to be a multiple and we have many values to whack....
1671         my $cf_values = $values->Count;
1672
1673         if ( $cf_values > $cf->MaxValues ) {
1674             my $i = 0;   #We want to delete all but the max we can currently have , so we can then
1675                  # execute the same code to "change" the value from old to new
1676             while ( my $value = $values->Next ) {
1677                 $i++;
1678                 if ( $i < $cf_values ) {
1679                     my ( $val, $msg ) = $cf->DeleteValueForObject(
1680                         Object  => $self,
1681                         Content => $value->Content
1682                     );
1683                     unless ($val) {
1684                         return ( 0, $msg );
1685                     }
1686                     my ( $TransactionId, $Msg, $TransactionObj ) =
1687                       $self->_NewTransaction(
1688                         Type         => 'CustomField',
1689                         Field        => $cf->Id,
1690                         OldReference => $value,
1691                       );
1692                 }
1693             }
1694             $values->RedoSearch if $i; # redo search if have deleted at least one value
1695         }
1696
1697         my ( $old_value, $old_content );
1698         if ( $old_value = $values->First ) {
1699             $old_content = $old_value->Content();
1700             return (1) if( $old_content eq $args{'Value'} && $old_value->LargeContent eq $args{'LargeContent'});;
1701         }
1702
1703         my ( $new_value_id, $value_msg ) = $cf->AddValueForObject(
1704             Object       => $self,
1705             Content      => $args{'Value'},
1706             LargeContent => $args{'LargeContent'},
1707             ContentType  => $args{'ContentType'},
1708         );
1709
1710         unless ($new_value_id) {
1711             return ( 0, $self->loc( "Could not add new custom field value: [_1]", $value_msg) );
1712         }
1713
1714         my $new_value = RT::ObjectCustomFieldValue->new( $self->CurrentUser );
1715         $new_value->Load($new_value_id);
1716
1717         # now that adding the new value was successful, delete the old one
1718         if ($old_value) {
1719             my ( $val, $msg ) = $old_value->Delete();
1720             unless ($val) {
1721                 return ( 0, $msg );
1722             }
1723         }
1724
1725         if ( $args{'RecordTransaction'} ) {
1726             my ( $TransactionId, $Msg, $TransactionObj ) =
1727               $self->_NewTransaction(
1728                 Type         => 'CustomField',
1729                 Field        => $cf->Id,
1730                 OldReference => $old_value,
1731                 NewReference => $new_value,
1732               );
1733         }
1734
1735         if ( $old_value eq '' ) {
1736             return ( 1, $self->loc( "[_1] [_2] added", $cf->Name, $new_value->Content ));
1737         }
1738         elsif ( $new_value->Content eq '' ) {
1739             return ( 1,
1740                 $self->loc( "[_1] [_2] deleted", $cf->Name, $old_value->Content ) );
1741         }
1742         else {
1743             return ( 1, $self->loc( "[_1] [_2] changed to [_3]", $cf->Name, $old_content,                $new_value->Content));
1744         }
1745
1746     }
1747
1748     # otherwise, just add a new value and record "new value added"
1749     else {
1750         my ($new_value_id, $value_msg) = $cf->AddValueForObject(
1751             Object       => $self,
1752             Content      => $args{'Value'},
1753             LargeContent => $args{'LargeContent'},
1754             ContentType  => $args{'ContentType'},
1755         );
1756
1757         unless ($new_value_id) {
1758             return ( 0, $self->loc( "Could not add new custom field value: [_1]", $value_msg) );
1759         }
1760         if ( $args{'RecordTransaction'} ) {
1761             my ( $TransactionId, $Msg, $TransactionObj ) =
1762               $self->_NewTransaction(
1763                 Type          => 'CustomField',
1764                 Field         => $cf->Id,
1765                 NewReference  => $new_value_id,
1766                 ReferenceType => 'RT::ObjectCustomFieldValue',
1767               );
1768             unless ($TransactionId) {
1769                 return ( 0,
1770                     $self->loc( "Couldn't create a transaction: [_1]", $Msg ) );
1771             }
1772         }
1773         return ( 1, $self->loc( "[_1] added as a value for [_2]", $args{'Value'}, $cf->Name));
1774     }
1775
1776 }
1777
1778 # }}}
1779
1780 # {{{ DeleteCustomFieldValue
1781
1782 =head2 DeleteCustomFieldValue { Field => FIELD, Value => VALUE }
1783
1784 Deletes VALUE as a value of CustomField FIELD.
1785
1786 VALUE can be a string, a CustomFieldValue or a ObjectCustomFieldValue.
1787
1788 If VALUE is not a valid value for the custom field, returns
1789 (0, 'Error message' ) otherwise, returns (1, 'Success Message')
1790
1791 =cut
1792
1793 sub DeleteCustomFieldValue {
1794     my $self = shift;
1795     my %args = (
1796         Field   => undef,
1797         Value   => undef,
1798         ValueId => undef,
1799         @_
1800     );
1801
1802     my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
1803
1804     unless ( $cf->Id ) {
1805         return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
1806     }
1807     my ( $val, $msg ) = $cf->DeleteValueForObject(
1808         Object  => $self,
1809         Id      => $args{'ValueId'},
1810         Content => $args{'Value'},
1811     );
1812     unless ($val) {
1813         return ( 0, $msg );
1814     }
1815     my ( $TransactionId, $Msg, $TransactionObj ) = $self->_NewTransaction(
1816         Type          => 'CustomField',
1817         Field         => $cf->Id,
1818         OldReference  => $val,
1819         ReferenceType => 'RT::ObjectCustomFieldValue',
1820     );
1821     unless ($TransactionId) {
1822         return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $Msg ) );
1823     }
1824
1825     return (
1826         $TransactionId,
1827         $self->loc(
1828             "[_1] is no longer a value for custom field [_2]",
1829             $TransactionObj->OldValue, $cf->Name
1830         )
1831     );
1832 }
1833
1834 # }}}
1835
1836 # {{{ FirstCustomFieldValue
1837
1838 =head2 FirstCustomFieldValue FIELD
1839
1840 Return the content of the first value of CustomField FIELD for this ticket
1841 Takes a field id or name
1842
1843 =cut
1844
1845 sub FirstCustomFieldValue {
1846     my $self = shift;
1847     my $field = shift;
1848     my $values = $self->CustomFieldValues($field);
1849     if ($values->First) {
1850         return $values->First->Content;
1851     } else {
1852         return undef;
1853     }
1854
1855 }
1856
1857
1858
1859 # {{{ CustomFieldValues
1860
1861 =head2 CustomFieldValues FIELD
1862
1863 Return a ObjectCustomFieldValues object of all values of the CustomField whose
1864 id or Name is FIELD for this record.
1865
1866 Returns an RT::ObjectCustomFieldValues object
1867
1868 =cut
1869
1870 sub CustomFieldValues {
1871     my $self  = shift;
1872     my $field = shift;
1873
1874     if ($field) {
1875         my $cf = $self->LoadCustomFieldByIdentifier($field);
1876
1877         # we were asked to search on a custom field we couldn't fine
1878         unless ( $cf->id ) {
1879             return RT::ObjectCustomFieldValues->new( $self->CurrentUser );
1880         }
1881         return ( $cf->ValuesForObject($self) );
1882     }
1883
1884     # we're not limiting to a specific custom field;
1885     my $ocfs = RT::ObjectCustomFieldValues->new( $self->CurrentUser );
1886     $ocfs->LimitToObject($self);
1887     return $ocfs;
1888
1889 }
1890
1891 =head2 CustomField IDENTIFER
1892
1893 Find the custom field has id or name IDENTIFIER for this object.
1894
1895 If no valid field is found, returns an empty RT::CustomField object.
1896
1897 =cut
1898
1899 sub LoadCustomFieldByIdentifier {
1900     my $self = shift;
1901     my $field = shift;
1902
1903     my $cf = RT::CustomField->new($self->CurrentUser);
1904
1905     if ( UNIVERSAL::isa( $field, "RT::CustomField" ) ) {
1906         $cf->LoadById( $field->id );
1907     }
1908     elsif ($field =~ /^\d+$/) {
1909         $cf = RT::CustomField->new($self->CurrentUser);
1910         $cf->Load($field);
1911     } else {
1912
1913         my $cfs = $self->CustomFields($self->CurrentUser);
1914         $cfs->Limit(FIELD => 'Name', VALUE => $field, CASESENSITIVE => 0);
1915         $cf = $cfs->First || RT::CustomField->new($self->CurrentUser);
1916     }
1917     return $cf;
1918 }
1919
1920
1921 # }}}
1922
1923 # }}}
1924
1925 # }}}
1926
1927 sub BasicColumns {
1928 }
1929
1930 sub WikiBase {
1931   return $RT::WebPath. "/index.html?q=";
1932 }
1933
1934 eval "require RT::Record_Vendor";
1935 die $@ if ($@ && $@ !~ qr{^Can't locate RT/Record_Vendor.pm});
1936 eval "require RT::Record_Local";
1937 die $@ if ($@ && $@ !~ qr{^Can't locate RT/Record_Local.pm});
1938
1939 1;