rt/lib/RT/Record.pm

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