rt/lib/RT/Record.pm

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