rt/lib/RT/Record.pm

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