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         CustomFields => {},
1471         @_
1472     );
1473
1474     my $old_ref = $args{'OldReference'};
1475     my $new_ref = $args{'NewReference'};
1476     my $ref_type = $args{'ReferenceType'};
1477     if ($old_ref or $new_ref) {
1478         $ref_type ||= ref($old_ref) || ref($new_ref);
1479         if (!$ref_type) {
1480             $RT::Logger->error("Reference type not specified for transaction");
1481             return;
1482         }
1483         $old_ref = $old_ref->Id if ref($old_ref);
1484         $new_ref = $new_ref->Id if ref($new_ref);
1485     }
1486
1487     require RT::Transaction;
1488     my $trans = new RT::Transaction( $self->CurrentUser );
1489     my ( $transaction, $msg ) = $trans->Create(
1490         ObjectId  => $self->Id,
1491         ObjectType => ref($self),
1492         TimeTaken => $args{'TimeTaken'},
1493         Type      => $args{'Type'},
1494         Data      => $args{'Data'},
1495         Field     => $args{'Field'},
1496         NewValue  => $args{'NewValue'},
1497         OldValue  => $args{'OldValue'},
1498         NewReference  => $new_ref,
1499         OldReference  => $old_ref,
1500         ReferenceType => $ref_type,
1501         MIMEObj   => $args{'MIMEObj'},
1502         ActivateScrips => $args{'ActivateScrips'},
1503         CommitScrips => $args{'CommitScrips'},
1504         CustomFields => $args{'CustomFields'},
1505     );
1506
1507     # Rationalize the object since we may have done things to it during the caching.
1508     $self->Load($self->Id);
1509
1510     $RT::Logger->warning($msg) unless $transaction;
1511
1512     $self->_SetLastUpdated;
1513
1514     if ( defined $args{'TimeTaken'} and $self->can('_UpdateTimeTaken')) {
1515         $self->_UpdateTimeTaken( $args{'TimeTaken'} );
1516     }
1517     if ( RT->Config->Get('UseTransactionBatch') and $transaction ) {
1518             push @{$self->{_TransactionBatch}}, $trans if $args{'CommitScrips'};
1519     }
1520     return ( $transaction, $msg, $trans );
1521 }
1522
1523 # }}}
1524
1525 # {{{ sub Transactions
1526
1527 =head2 Transactions
1528
1529   Returns an RT::Transactions object of all transactions on this record object
1530
1531 =cut
1532
1533 sub Transactions {
1534     my $self = shift;
1535
1536     use RT::Transactions;
1537     my $transactions = RT::Transactions->new( $self->CurrentUser );
1538
1539     #If the user has no rights, return an empty object
1540     $transactions->Limit(
1541         FIELD => 'ObjectId',
1542         VALUE => $self->id,
1543     );
1544     $transactions->Limit(
1545         FIELD => 'ObjectType',
1546         VALUE => ref($self),
1547     );
1548
1549     return ($transactions);
1550 }
1551
1552 # }}}
1553 # }}}
1554 #
1555 # {{{ Routines dealing with custom fields
1556
1557 sub CustomFields {
1558     my $self = shift;
1559     my $cfs  = RT::CustomFields->new( $self->CurrentUser );
1560
1561     $cfs->SetContextObject( $self );
1562     # XXX handle multiple types properly
1563     $cfs->LimitToLookupType( $self->CustomFieldLookupType );
1564     $cfs->LimitToGlobalOrObjectId(
1565         $self->_LookupId( $self->CustomFieldLookupType )
1566     );
1567     $cfs->ApplySortOrder;
1568
1569     return $cfs;
1570 }
1571
1572 # TODO: This _only_ works for RT::Class classes. it doesn't work, for example, for RT::FM classes.
1573
1574 sub _LookupId {
1575     my $self = shift;
1576     my $lookup = shift;
1577     my @classes = ($lookup =~ /RT::(\w+)-/g);
1578
1579     my $object = $self;
1580     foreach my $class (reverse @classes) {
1581         my $method = "${class}Obj";
1582         $object = $object->$method;
1583     }
1584
1585     return $object->Id;
1586 }
1587
1588
1589 =head2 CustomFieldLookupType
1590
1591 Returns the path RT uses to figure out which custom fields apply to this object.
1592
1593 =cut
1594
1595 sub CustomFieldLookupType {
1596     my $self = shift;
1597     return ref($self);
1598 }
1599
1600 # {{{ AddCustomFieldValue
1601
1602 =head2 AddCustomFieldValue { Field => FIELD, Value => VALUE }
1603
1604 VALUE should be a string. FIELD can be any identifier of a CustomField
1605 supported by L</LoadCustomFieldByIdentifier> method.
1606
1607 Adds VALUE as a value of CustomField FIELD. If this is a single-value custom field,
1608 deletes the old value.
1609 If VALUE is not a valid value for the custom field, returns
1610 (0, 'Error message' ) otherwise, returns ($id, 'Success Message') where
1611 $id is ID of created L<ObjectCustomFieldValue> object.
1612
1613 =cut
1614
1615 sub AddCustomFieldValue {
1616     my $self = shift;
1617     $self->_AddCustomFieldValue(@_);
1618 }
1619
1620 sub _AddCustomFieldValue {
1621     my $self = shift;
1622     my %args = (
1623         Field             => undef,
1624         Value             => undef,
1625         LargeContent      => undef,
1626         ContentType       => undef,
1627         RecordTransaction => 1,
1628         @_
1629     );
1630
1631     my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
1632     unless ( $cf->Id ) {
1633         return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
1634     }
1635
1636     my $OCFs = $self->CustomFields;
1637     $OCFs->Limit( FIELD => 'id', VALUE => $cf->Id );
1638     unless ( $OCFs->Count ) {
1639         return (
1640             0,
1641             $self->loc(
1642                 "Custom field [_1] does not apply to this object",
1643                 $args{'Field'}
1644             )
1645         );
1646     }
1647
1648     # empty string is not correct value of any CF, so undef it
1649     foreach ( qw(Value LargeContent) ) {
1650         $args{ $_ } = undef if defined $args{ $_ } && !length $args{ $_ };
1651     }
1652
1653     unless ( $cf->ValidateValue( $args{'Value'} ) ) {
1654         return ( 0, $self->loc("Invalid value for custom field") );
1655     }
1656
1657     # If the custom field only accepts a certain # of values, delete the existing
1658     # value and record a "changed from foo to bar" transaction
1659     unless ( $cf->UnlimitedValues ) {
1660
1661         # Load up a ObjectCustomFieldValues object for this custom field and this ticket
1662         my $values = $cf->ValuesForObject($self);
1663
1664         # We need to whack any old values here.  In most cases, the custom field should
1665         # only have one value to delete.  In the pathalogical case, this custom field
1666         # used to be a multiple and we have many values to whack....
1667         my $cf_values = $values->Count;
1668
1669         if ( $cf_values > $cf->MaxValues ) {
1670             my $i = 0;   #We want to delete all but the max we can currently have , so we can then
1671                  # execute the same code to "change" the value from old to new
1672             while ( my $value = $values->Next ) {
1673                 $i++;
1674                 if ( $i < $cf_values ) {
1675                     my ( $val, $msg ) = $cf->DeleteValueForObject(
1676                         Object  => $self,
1677                         Content => $value->Content
1678                     );
1679                     unless ($val) {
1680                         return ( 0, $msg );
1681                     }
1682                     my ( $TransactionId, $Msg, $TransactionObj ) =
1683                       $self->_NewTransaction(
1684                         Type         => 'CustomField',
1685                         Field        => $cf->Id,
1686                         OldReference => $value,
1687                       );
1688                 }
1689             }
1690             $values->RedoSearch if $i; # redo search if have deleted at least one value
1691         }
1692
1693         my ( $old_value, $old_content );
1694         if ( $old_value = $values->First ) {
1695             $old_content = $old_value->Content;
1696             $old_content = undef if defined $old_content && !length $old_content;
1697
1698             my $is_the_same = 1;
1699             if ( defined $args{'Value'} ) {
1700                 $is_the_same = 0 unless defined $old_content
1701                     && lc $old_content eq lc $args{'Value'};
1702             } else {
1703                 $is_the_same = 0 if defined $old_content;
1704             }
1705             if ( $is_the_same ) {
1706                 my $old_content = $old_value->LargeContent;
1707                 if ( defined $args{'LargeContent'} ) {
1708                     $is_the_same = 0 unless defined $old_content
1709                         && $old_content eq $args{'LargeContent'};
1710                 } else {
1711                     $is_the_same = 0 if defined $old_content;
1712                 }
1713             }
1714
1715             return $old_value->id if $is_the_same;
1716         }
1717
1718         my ( $new_value_id, $value_msg ) = $cf->AddValueForObject(
1719             Object       => $self,
1720             Content      => $args{'Value'},
1721             LargeContent => $args{'LargeContent'},
1722             ContentType  => $args{'ContentType'},
1723         );
1724
1725         unless ( $new_value_id ) {
1726             return ( 0, $self->loc( "Could not add new custom field value: [_1]", $value_msg ) );
1727         }
1728
1729         my $new_value = RT::ObjectCustomFieldValue->new( $self->CurrentUser );
1730         $new_value->Load( $new_value_id );
1731
1732         # now that adding the new value was successful, delete the old one
1733         if ( $old_value ) {
1734             my ( $val, $msg ) = $old_value->Delete();
1735             return ( 0, $msg ) unless $val;
1736         }
1737
1738         if ( $args{'RecordTransaction'} ) {
1739             my ( $TransactionId, $Msg, $TransactionObj ) =
1740               $self->_NewTransaction(
1741                 Type         => 'CustomField',
1742                 Field        => $cf->Id,
1743                 OldReference => $old_value,
1744                 NewReference => $new_value,
1745               );
1746         }
1747
1748         my $new_content = $new_value->Content;
1749
1750         # For date, we need to display them in "human" format in result message
1751         if ($cf->Type eq 'Date') {
1752             my $DateObj = new RT::Date( $self->CurrentUser );
1753             $DateObj->Set(
1754                 Format => 'ISO',
1755                 Value  => $new_content,
1756             );
1757             $new_content = $DateObj->AsString;
1758
1759             if ( defined $old_content && length $old_content ) {
1760                 $DateObj->Set(
1761                     Format => 'ISO',
1762                     Value  => $old_content,
1763                 );
1764                 $old_content = $DateObj->AsString;
1765             }
1766         }
1767
1768         unless ( defined $old_content && length $old_content ) {
1769             return ( $new_value_id, $self->loc( "[_1] [_2] added", $cf->Name, $new_content ));
1770         }
1771         elsif ( !defined $new_content || !length $new_content ) {
1772             return ( $new_value_id,
1773                 $self->loc( "[_1] [_2] deleted", $cf->Name, $old_content ) );
1774         }
1775         else {
1776             return ( $new_value_id, $self->loc( "[_1] [_2] changed to [_3]", $cf->Name, $old_content, $new_content));
1777         }
1778
1779     }
1780
1781     # otherwise, just add a new value and record "new value added"
1782     else {
1783         my ($new_value_id, $msg) = $cf->AddValueForObject(
1784             Object       => $self,
1785             Content      => $args{'Value'},
1786             LargeContent => $args{'LargeContent'},
1787             ContentType  => $args{'ContentType'},
1788         );
1789
1790         unless ( $new_value_id ) {
1791             return ( 0, $self->loc( "Could not add new custom field value: [_1]", $msg ) );
1792         }
1793         if ( $args{'RecordTransaction'} ) {
1794             my ( $tid, $msg ) = $self->_NewTransaction(
1795                 Type          => 'CustomField',
1796                 Field         => $cf->Id,
1797                 NewReference  => $new_value_id,
1798                 ReferenceType => 'RT::ObjectCustomFieldValue',
1799             );
1800             unless ( $tid ) {
1801                 return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $msg ) );
1802             }
1803         }
1804         return ( $new_value_id, $self->loc( "[_1] added as a value for [_2]", $args{'Value'}, $cf->Name ) );
1805     }
1806 }
1807
1808 # }}}
1809
1810 # {{{ DeleteCustomFieldValue
1811
1812 =head2 DeleteCustomFieldValue { Field => FIELD, Value => VALUE }
1813
1814 Deletes VALUE as a value of CustomField FIELD.
1815
1816 VALUE can be a string, a CustomFieldValue or a ObjectCustomFieldValue.
1817
1818 If VALUE is not a valid value for the custom field, returns
1819 (0, 'Error message' ) otherwise, returns (1, 'Success Message')
1820
1821 =cut
1822
1823 sub DeleteCustomFieldValue {
1824     my $self = shift;
1825     my %args = (
1826         Field   => undef,
1827         Value   => undef,
1828         ValueId => undef,
1829         @_
1830     );
1831
1832     my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
1833     unless ( $cf->Id ) {
1834         return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
1835     }
1836
1837     my ( $val, $msg ) = $cf->DeleteValueForObject(
1838         Object  => $self,
1839         Id      => $args{'ValueId'},
1840         Content => $args{'Value'},
1841     );
1842     unless ($val) {
1843         return ( 0, $msg );
1844     }
1845
1846     my ( $TransactionId, $Msg, $TransactionObj ) = $self->_NewTransaction(
1847         Type          => 'CustomField',
1848         Field         => $cf->Id,
1849         OldReference  => $val,
1850         ReferenceType => 'RT::ObjectCustomFieldValue',
1851     );
1852     unless ($TransactionId) {
1853         return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $Msg ) );
1854     }
1855
1856     my $old_value = $TransactionObj->OldValue;
1857     # For date, we need to display them in "human" format in result message
1858     if ( $cf->Type eq 'Date' ) {
1859         my $DateObj = new RT::Date( $self->CurrentUser );
1860         $DateObj->Set(
1861             Format => 'ISO',
1862             Value  => $old_value,
1863         );
1864         $old_value = $DateObj->AsString;
1865     }
1866     return (
1867         $TransactionId,
1868         $self->loc(
1869             "[_1] is no longer a value for custom field [_2]",
1870             $old_value, $cf->Name
1871         )
1872     );
1873 }
1874
1875 # }}}
1876
1877 # {{{ FirstCustomFieldValue
1878
1879 =head2 FirstCustomFieldValue FIELD
1880
1881 Return the content of the first value of CustomField FIELD for this ticket
1882 Takes a field id or name
1883
1884 =cut
1885
1886 sub FirstCustomFieldValue {
1887     my $self = shift;
1888     my $field = shift;
1889
1890     my $values = $self->CustomFieldValues( $field );
1891     return undef unless my $first = $values->First;
1892     return $first->Content;
1893 }
1894
1895 =head2 CustomFieldValuesAsString FIELD
1896
1897 Return the content of the CustomField FIELD for this ticket.
1898 If this is a multi-value custom field, values will be joined with newlines.
1899
1900 Takes a field id or name as the first argument
1901
1902 Takes an optional Separator => "," second and third argument
1903 if you want to join the values using something other than a newline
1904
1905 =cut
1906
1907 sub CustomFieldValuesAsString {
1908     my $self  = shift;
1909     my $field = shift;
1910     my %args  = @_;
1911     my $separator = $args{Separator} || "\n";
1912
1913     my $values = $self->CustomFieldValues( $field );
1914     return join ($separator, grep { defined $_ }
1915                  map { $_->Content } @{$values->ItemsArrayRef});
1916 }
1917
1918
1919 # {{{ CustomFieldValues
1920
1921 =head2 CustomFieldValues FIELD
1922
1923 Return a ObjectCustomFieldValues object of all values of the CustomField whose
1924 id or Name is FIELD for this record.
1925
1926 Returns an RT::ObjectCustomFieldValues object
1927
1928 =cut
1929
1930 sub CustomFieldValues {
1931     my $self  = shift;
1932     my $field = shift;
1933
1934     if ( $field ) {
1935         my $cf = $self->LoadCustomFieldByIdentifier( $field );
1936
1937         # we were asked to search on a custom field we couldn't find
1938         unless ( $cf->id ) {
1939             $RT::Logger->warning("Couldn't load custom field by '$field' identifier");
1940             return RT::ObjectCustomFieldValues->new( $self->CurrentUser );
1941         }
1942         return ( $cf->ValuesForObject($self) );
1943     }
1944
1945     # we're not limiting to a specific custom field;
1946     my $ocfs = RT::ObjectCustomFieldValues->new( $self->CurrentUser );
1947     $ocfs->LimitToObject( $self );
1948     return $ocfs;
1949 }
1950
1951 =head2 LoadCustomFieldByIdentifier IDENTIFER
1952
1953 Find the custom field has id or name IDENTIFIER for this object.
1954
1955 If no valid field is found, returns an empty RT::CustomField object.
1956
1957 =cut
1958
1959 sub LoadCustomFieldByIdentifier {
1960     my $self = shift;
1961     my $field = shift;
1962
1963     my $cf;
1964     if ( UNIVERSAL::isa( $field, "RT::CustomField" ) ) {
1965         $cf = RT::CustomField->new($self->CurrentUser);
1966         $cf->SetContextObject( $self );
1967         $cf->LoadById( $field->id );
1968     }
1969     elsif ($field =~ /^\d+$/) {
1970         $cf = RT::CustomField->new($self->CurrentUser);
1971         $cf->SetContextObject( $self );
1972         $cf->LoadById($field);
1973     } else {
1974
1975         my $cfs = $self->CustomFields($self->CurrentUser);
1976         $cfs->SetContextObject( $self );
1977         $cfs->Limit(FIELD => 'Name', VALUE => $field, CASESENSITIVE => 0);
1978         $cf = $cfs->First || RT::CustomField->new($self->CurrentUser);
1979     }
1980     return $cf;
1981 }
1982
1983 sub ACLEquivalenceObjects { }
1984
1985 sub BasicColumns { }
1986
1987 sub WikiBase {
1988     return RT->Config->Get('WebPath'). "/index.html?q=";
1989 }
1990
1991 eval "require RT::Record_Vendor";
1992 die $@ if ($@ && $@ !~ qr{^Can't locate RT/Record_Vendor.pm});
1993 eval "require RT::Record_Local";
1994 die $@ if ($@ && $@ !~ qr{^Can't locate RT/Record_Local.pm});
1995
1996 1;