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     if ( $args{'decode_utf8'} ) {
 643         if ( !utf8::is_utf8($value) ) {
 644             utf8::decode($value);
 645         }
 646     }
 647     else {
 648         if ( utf8::is_utf8($value) ) {
 649             utf8::encode($value);
 650         }
 651     }
 652
 653     return $value;
 654
 655 }
 656
 657 # Set up defaults for DBIx::SearchBuilder::Record::Cachable
 658
 659 sub _CacheConfig {
 660   {
 661      'cache_p'        => 1,
 662      'cache_for_sec'  => 30,
 663   }
 664 }
 665
 666
 667
 668 sub _BuildTableAttributes {
 669     my $self = shift;
 670     my $class = ref($self) || $self;
 671
 672     my $attributes;
 673     if ( UNIVERSAL::can( $self, '_CoreAccessible' ) ) {
 674        $attributes = $self->_CoreAccessible();
 675     } elsif ( UNIVERSAL::can( $self, '_ClassAccessible' ) ) {
 676        $attributes = $self->_ClassAccessible();
 677
 678     }
 679
 680     foreach my $column (keys %$attributes) {
 681         foreach my $attr ( keys %{ $attributes->{$column} } ) {
 682             $_TABLE_ATTR->{$class}->{$column}->{$attr} = $attributes->{$column}->{$attr};
 683         }
 684     }
 685     foreach my $method ( qw(_OverlayAccessible _VendorAccessible _LocalAccessible) ) {
 686         next unless UNIVERSAL::can( $self, $method );
 687         $attributes = $self->$method();
 688
 689         foreach my $column ( keys %$attributes ) {
 690             foreach my $attr ( keys %{ $attributes->{$column} } ) {
 691                 $_TABLE_ATTR->{$class}->{$column}->{$attr} = $attributes->{$column}->{$attr};
 692             }
 693         }
 694     }
 695 }
 696
 697
 698 =head2 _ClassAccessible
 699
 700 Overrides the "core" _ClassAccessible using $_TABLE_ATTR. Behaves identical to the version in
 701 DBIx::SearchBuilder::Record
 702
 703 =cut
 704
 705 sub _ClassAccessible {
 706     my $self = shift;
 707     return $_TABLE_ATTR->{ref($self) || $self};
 708 }
 709
 710 =head2 _Accessible COLUMN ATTRIBUTE
 711
 712 returns the value of ATTRIBUTE for COLUMN
 713
 714
 715 =cut
 716
 717 sub _Accessible  {
 718   my $self = shift;
 719   my $column = shift;
 720   my $attribute = lc(shift);
 721   return 0 unless defined ($_TABLE_ATTR->{ref($self)}->{$column});
 722   return $_TABLE_ATTR->{ref($self)}->{$column}->{$attribute} || 0;
 723
 724 }
 725
 726 =head2 _EncodeLOB BODY MIME_TYPE
 727
 728 Takes a potentially large attachment. Returns (ContentEncoding, EncodedBody) based on system configuration and selected database
 729
 730 =cut
 731
 732 sub _EncodeLOB {
 733         my $self = shift;
 734         my $Body = shift;
 735         my $MIMEType = shift || '';
 736         my $Filename = shift;
 737
 738         my $ContentEncoding = 'none';
 739
 740         #get the max attachment length from RT
 741         my $MaxSize = RT->Config->Get('MaxAttachmentSize');
 742
 743         #if the current attachment contains nulls and the
 744         #database doesn't support embedded nulls
 745
 746         if ( ( !$RT::Handle->BinarySafeBLOBs ) && ( $Body =~ /\x00/ ) ) {
 747
 748             # set a flag telling us to mimencode the attachment
 749             $ContentEncoding = 'base64';
 750
 751             #cut the max attchment size by 25% (for mime-encoding overhead.
 752             $RT::Logger->debug("Max size is $MaxSize");
 753             $MaxSize = $MaxSize * 3 / 4;
 754         # Some databases (postgres) can't handle non-utf8 data
 755         } elsif (    !$RT::Handle->BinarySafeBLOBs
 756                   && $MIMEType !~ /text\/plain/gi
 757                   && !Encode::is_utf8( $Body, 1 ) ) {
 758               $ContentEncoding = 'quoted-printable';
 759         }
 760
 761         #if the attachment is larger than the maximum size
 762         if ( ($MaxSize) and ( $MaxSize < length($Body) ) ) {
 763
 764             # if we're supposed to truncate large attachments
 765             if (RT->Config->Get('TruncateLongAttachments')) {
 766
 767                 # truncate the attachment to that length.
 768                 $Body = substr( $Body, 0, $MaxSize );
 769
 770             }
 771
 772             # elsif we're supposed to drop large attachments on the floor,
 773             elsif (RT->Config->Get('DropLongAttachments')) {
 774
 775                 # drop the attachment on the floor
 776                 $RT::Logger->info( "$self: Dropped an attachment of size "
 777                                    . length($Body));
 778                 $RT::Logger->info( "It started: " . substr( $Body, 0, 60 ) );
 779                 $Filename .= ".txt" if $Filename;
 780                 return ("none", "Large attachment dropped", "plain/text", $Filename );
 781             }
 782         }
 783
 784         # if we need to mimencode the attachment
 785         if ( $ContentEncoding eq 'base64' ) {
 786
 787             # base64 encode the attachment
 788             Encode::_utf8_off($Body);
 789             $Body = MIME::Base64::encode_base64($Body);
 790
 791         } elsif ($ContentEncoding eq 'quoted-printable') {
 792             Encode::_utf8_off($Body);
 793             $Body = MIME::QuotedPrint::encode($Body);
 794         }
 795
 796
 797         return ($ContentEncoding, $Body, $MIMEType, $Filename );
 798
 799 }
 800
 801 sub _DecodeLOB {
 802     my $self            = shift;
 803     my $ContentType     = shift || '';
 804     my $ContentEncoding = shift || 'none';
 805     my $Content         = shift;
 806
 807     if ( $ContentEncoding eq 'base64' ) {
 808         $Content = MIME::Base64::decode_base64($Content);
 809     }
 810     elsif ( $ContentEncoding eq 'quoted-printable' ) {
 811         $Content = MIME::QuotedPrint::decode($Content);
 812     }
 813     elsif ( $ContentEncoding && $ContentEncoding ne 'none' ) {
 814         return ( $self->loc( "Unknown ContentEncoding [_1]", $ContentEncoding ) );
 815     }
 816     if ( RT::I18N::IsTextualContentType($ContentType) ) {
 817        $Content = Encode::decode_utf8($Content) unless Encode::is_utf8($Content);
 818     }
 819         return ($Content);
 820 }
 821
 822 # A helper table for links mapping to make it easier
 823 # to build and parse links between tickets
 824
 825 use vars '%LINKDIRMAP';
 826
 827 %LINKDIRMAP = (
 828     MemberOf => { Base => 'MemberOf',
 829                   Target => 'HasMember', },
 830     RefersTo => { Base => 'RefersTo',
 831                 Target => 'ReferredToBy', },
 832     DependsOn => { Base => 'DependsOn',
 833                    Target => 'DependedOnBy', },
 834     MergedInto => { Base => 'MergedInto',
 835                    Target => 'MergedInto', },
 836
 837 );
 838
 839 =head2 Update  ARGSHASH
 840
 841 Updates fields on an object for you using the proper Set methods,
 842 skipping unchanged values.
 843
 844  ARGSRef => a hashref of attributes => value for the update
 845  AttributesRef => an arrayref of keys in ARGSRef that should be updated
 846  AttributePrefix => a prefix that should be added to the attributes in AttributesRef
 847                     when looking up values in ARGSRef
 848                     Bare attributes are tried before prefixed attributes
 849
 850 Returns a list of localized results of the update
 851
 852 =cut
 853
 854 sub Update {
 855     my $self = shift;
 856
 857     my %args = (
 858         ARGSRef         => undef,
 859         AttributesRef   => undef,
 860         AttributePrefix => undef,
 861         @_
 862     );
 863
 864     my $attributes = $args{'AttributesRef'};
 865     my $ARGSRef    = $args{'ARGSRef'};
 866     my %new_values;
 867
 868     # gather all new values
 869     foreach my $attribute (@$attributes) {
 870         my $value;
 871         if ( defined $ARGSRef->{$attribute} ) {
 872             $value = $ARGSRef->{$attribute};
 873         }
 874         elsif (
 875             defined( $args{'AttributePrefix'} )
 876             && defined(
 877                 $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute }
 878             )
 879           ) {
 880             $value = $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute };
 881
 882         }
 883         else {
 884             next;
 885         }
 886
 887         $value =~ s/\r\n/\n/gs;
 888
 889         # If Queue is 'General', we want to resolve the queue name for
 890         # the object.
 891
 892         # This is in an eval block because $object might not exist.
 893         # and might not have a Name method. But "can" won't find autoloaded
 894         # items. If it fails, we don't care
 895         do {
 896             no warnings "uninitialized";
 897             local $@;
 898             eval {
 899                 my $object = $attribute . "Obj";
 900                 my $name = $self->$object->Name;
 901                 next if $name eq $value || $name eq ($value || 0);
 902             };
 903             next if $value eq $self->$attribute();
 904             next if ($value || 0) eq $self->$attribute();
 905         };
 906
 907         $new_values{$attribute} = $value;
 908     }
 909
 910     return $self->_UpdateAttributes(
 911         Attributes => $attributes,
 912         NewValues  => \%new_values,
 913     );
 914 }
 915
 916 sub _UpdateAttributes {
 917     my $self = shift;
 918     my %args = (
 919         Attributes => [],
 920         NewValues  => {},
 921         @_,
 922     );
 923
 924     my @results;
 925
 926     foreach my $attribute (@{ $args{Attributes} }) {
 927         next if !exists($args{NewValues}{$attribute});
 928
 929         my $value = $args{NewValues}{$attribute};
 930         my $method = "Set$attribute";
 931         my ( $code, $msg ) = $self->$method($value);
 932         my ($prefix) = ref($self) =~ /RT(?:.*)::(\w+)/;
 933
 934         # Default to $id, but use name if we can get it.
 935         my $label = $self->id;
 936         $label = $self->Name if (UNIVERSAL::can($self,'Name'));
 937         # this requires model names to be loc'ed.
 938
 939 =for loc
 940
 941     "Ticket" # loc
 942     "User" # loc
 943     "Group" # loc
 944     "Queue" # loc
 945
 946 =cut
 947
 948         push @results, $self->loc( $prefix ) . " $label: ". $msg;
 949
 950 =for loc
 951
 952                                    "[_1] could not be set to [_2].",       # loc
 953                                    "That is already the current value",    # loc
 954                                    "No value sent to _Set!",               # loc
 955                                    "Illegal value for [_1]",               # loc
 956                                    "The new value has been set.",          # loc
 957                                    "No column specified",                  # loc
 958                                    "Immutable field",                      # loc
 959                                    "Nonexistant field?",                   # loc
 960                                    "Invalid data",                         # loc
 961                                    "Couldn't find row",                    # loc
 962                                    "Missing a primary key?: [_1]",         # loc
 963                                    "Found Object",                         # loc
 964
 965 =cut
 966
 967     }
 968
 969     return @results;
 970 }
 971
 972
 973
 974
 975 =head2 Members
 976
 977   This returns an RT::Links object which references all the tickets
 978 which are 'MembersOf' this ticket
 979
 980 =cut
 981
 982 sub Members {
 983     my $self = shift;
 984     return ( $self->_Links( 'Target', 'MemberOf' ) );
 985 }
 986
 987
 988
 989 =head2 MemberOf
 990
 991   This returns an RT::Links object which references all the tickets that this
 992 ticket is a 'MemberOf'
 993
 994 =cut
 995
 996 sub MemberOf {
 997     my $self = shift;
 998     return ( $self->_Links( 'Base', 'MemberOf' ) );
 999 }
1000
1001
1002
1003 =head2 RefersTo
1004
1005   This returns an RT::Links object which shows all references for which this ticket is a base
1006
1007 =cut
1008
1009 sub RefersTo {
1010     my $self = shift;
1011     return ( $self->_Links( 'Base', 'RefersTo' ) );
1012 }
1013
1014
1015
1016 =head2 ReferredToBy
1017
1018 This returns an L<RT::Links> object which shows all references for which this ticket is a target
1019
1020 =cut
1021
1022 sub ReferredToBy {
1023     my $self = shift;
1024     return ( $self->_Links( 'Target', 'RefersTo' ) );
1025 }
1026
1027
1028
1029 =head2 DependedOnBy
1030
1031   This returns an RT::Links object which references all the tickets that depend on this one
1032
1033 =cut
1034
1035 sub DependedOnBy {
1036     my $self = shift;
1037     return ( $self->_Links( 'Target', 'DependsOn' ) );
1038 }
1039
1040
1041
1042
1043 =head2 HasUnresolvedDependencies
1044
1045 Takes a paramhash of Type (default to '__any').  Returns the number of
1046 unresolved dependencies, if $self->UnresolvedDependencies returns an
1047 object with one or more members of that type.  Returns false
1048 otherwise.
1049
1050 =cut
1051
1052 sub HasUnresolvedDependencies {
1053     my $self = shift;
1054     my %args = (
1055         Type   => undef,
1056         @_
1057     );
1058
1059     my $deps = $self->UnresolvedDependencies;
1060
1061     if ($args{Type}) {
1062         $deps->Limit( FIELD => 'Type',
1063               OPERATOR => '=',
1064               VALUE => $args{Type});
1065     }
1066     else {
1067             $deps->IgnoreType;
1068     }
1069
1070     if ($deps->Count > 0) {
1071         return $deps->Count;
1072     }
1073     else {
1074         return (undef);
1075     }
1076 }
1077
1078
1079
1080 =head2 UnresolvedDependencies
1081
1082 Returns an RT::Tickets object of tickets which this ticket depends on
1083 and which have a status of new, open or stalled. (That list comes from
1084 RT::Queue->ActiveStatusArray
1085
1086 =cut
1087
1088
1089 sub UnresolvedDependencies {
1090     my $self = shift;
1091     my $deps = RT::Tickets->new($self->CurrentUser);
1092
1093     my @live_statuses = RT::Queue->ActiveStatusArray();
1094     foreach my $status (@live_statuses) {
1095         $deps->LimitStatus(VALUE => $status);
1096     }
1097     $deps->LimitDependedOnBy($self->Id);
1098
1099     return($deps);
1100
1101 }
1102
1103
1104
1105 =head2 AllDependedOnBy
1106
1107 Returns an array of RT::Ticket objects which (directly or indirectly)
1108 depends on this ticket; takes an optional 'Type' argument in the param
1109 hash, which will limit returned tickets to that type, as well as cause
1110 tickets with that type to serve as 'leaf' nodes that stops the recursive
1111 dependency search.
1112
1113 =cut
1114
1115 sub AllDependedOnBy {
1116     my $self = shift;
1117     return $self->_AllLinkedTickets( LinkType => 'DependsOn',
1118                                      Direction => 'Target', @_ );
1119 }
1120
1121 =head2 AllDependsOn
1122
1123 Returns an array of RT::Ticket objects which this ticket (directly or
1124 indirectly) depends on; takes an optional 'Type' argument in the param
1125 hash, which will limit returned tickets to that type, as well as cause
1126 tickets with that type to serve as 'leaf' nodes that stops the
1127 recursive dependency search.
1128
1129 =cut
1130
1131 sub AllDependsOn {
1132     my $self = shift;
1133     return $self->_AllLinkedTickets( LinkType => 'DependsOn',
1134                                      Direction => 'Base', @_ );
1135 }
1136
1137 sub _AllLinkedTickets {
1138     my $self = shift;
1139
1140     my %args = (
1141         LinkType  => undef,
1142         Direction => undef,
1143         Type   => undef,
1144         _found => {},
1145         _top   => 1,
1146         @_
1147     );
1148
1149     my $dep = $self->_Links( $args{Direction}, $args{LinkType});
1150     while (my $link = $dep->Next()) {
1151         my $uri = $args{Direction} eq 'Target' ? $link->BaseURI : $link->TargetURI;
1152         next unless ($uri->IsLocal());
1153         my $obj = $args{Direction} eq 'Target' ? $link->BaseObj : $link->TargetObj;
1154         next if $args{_found}{$obj->Id};
1155
1156         if (!$args{Type}) {
1157             $args{_found}{$obj->Id} = $obj;
1158             $obj->_AllLinkedTickets( %args, _top => 0 );
1159         }
1160         elsif ($obj->Type and $obj->Type eq $args{Type}) {
1161             $args{_found}{$obj->Id} = $obj;
1162         }
1163         else {
1164             $obj->_AllLinkedTickets( %args, _top => 0 );
1165         }
1166     }
1167
1168     if ($args{_top}) {
1169         return map { $args{_found}{$_} } sort keys %{$args{_found}};
1170     }
1171     else {
1172         return 1;
1173     }
1174 }
1175
1176
1177
1178 =head2 DependsOn
1179
1180   This returns an RT::Links object which references all the tickets that this ticket depends on
1181
1182 =cut
1183
1184 sub DependsOn {
1185     my $self = shift;
1186     return ( $self->_Links( 'Base', 'DependsOn' ) );
1187 }
1188
1189 # }}}
1190
1191 # {{{ Customers
1192
1193 =head2 Customers
1194
1195   This returns an RT::Links object which references all the customers that
1196   this object is a member of.  This includes both explicitly linked customers
1197   and links implied by services.
1198
1199 =cut
1200
1201 sub Customers {
1202     my( $self, %opt ) = @_;
1203     my $Debug = $opt{'Debug'};
1204
1205     unless ( $self->{'Customers'} ) {
1206
1207       $self->{'Customers'} = $self->MemberOf->Clone;
1208
1209       for my $fstable (qw(cust_main cust_svc)) {
1210
1211         $self->{'Customers'}->Limit(
1212                                      FIELD    => 'Target',
1213                                      OPERATOR => 'STARTSWITH',
1214                                      VALUE    => "freeside://freeside/$fstable",
1215                                      ENTRYAGGREGATOR => 'OR',
1216                                      SUBCLAUSE => 'customers',
1217                                    );
1218       }
1219     }
1220
1221     warn "->Customers method called on $self; returning ".
1222          ref($self->{'Customers'}). ' object'
1223       if $Debug;
1224
1225     return $self->{'Customers'};
1226 }
1227
1228 # }}}
1229
1230 # {{{ Services
1231
1232 =head2 Services
1233
1234   This returns an RT::Links object which references all the services this
1235   object is a member of.
1236
1237 =cut
1238
1239 sub Services {
1240     my( $self, %opt ) = @_;
1241
1242     unless ( $self->{'Services'} ) {
1243
1244       $self->{'Services'} = $self->MemberOf->Clone;
1245
1246       $self->{'Services'}->Limit(
1247                                    FIELD    => 'Target',
1248                                    OPERATOR => 'STARTSWITH',
1249                                    VALUE    => "freeside://freeside/cust_svc",
1250                                  );
1251     }
1252
1253     return $self->{'Services'};
1254 }
1255
1256
1257
1258
1259
1260
1261 =head2 Links DIRECTION [TYPE]
1262
1263 Return links (L<RT::Links>) to/from this object.
1264
1265 DIRECTION is either 'Base' or 'Target'.
1266
1267 TYPE is a type of links to return, it can be omitted to get
1268 links of any type.
1269
1270 =cut
1271
1272 sub Links { shift->_Links(@_) }
1273
1274 sub _Links {
1275     my $self = shift;
1276
1277     #TODO: Field isn't the right thing here. but I ahave no idea what mnemonic ---
1278     #tobias meant by $f
1279     my $field = shift;
1280     my $type  = shift || "";
1281
1282     unless ( $self->{"$field$type"} ) {
1283         $self->{"$field$type"} = RT::Links->new( $self->CurrentUser );
1284             # at least to myself
1285             $self->{"$field$type"}->Limit( FIELD => $field,
1286                                            VALUE => $self->URI,
1287                                            ENTRYAGGREGATOR => 'OR' );
1288             $self->{"$field$type"}->Limit( FIELD => 'Type',
1289                                            VALUE => $type )
1290               if ($type);
1291     }
1292     return ( $self->{"$field$type"} );
1293 }
1294
1295
1296
1297
1298 =head2 FormatType
1299
1300 Takes a Type and returns a string that is more human readable.
1301
1302 =cut
1303
1304 sub FormatType{
1305     my $self = shift;
1306     my %args = ( Type => '',
1307                  @_
1308                );
1309     $args{Type} =~ s/([A-Z])/" " . lc $1/ge;
1310     $args{Type} =~ s/^\s+//;
1311     return $args{Type};
1312 }
1313
1314
1315
1316
1317 =head2 FormatLink
1318
1319 Takes either a Target or a Base and returns a string of human friendly text.
1320
1321 =cut
1322
1323 sub FormatLink {
1324     my $self = shift;
1325     my %args = ( Object => undef,
1326                  FallBack => '',
1327                  @_
1328                );
1329     my $text = "URI " . $args{FallBack};
1330     if ($args{Object} && $args{Object}->isa("RT::Ticket")) {
1331         $text = "Ticket " . $args{Object}->id;
1332     }
1333     return $text;
1334 }
1335
1336
1337
1338 =head2 _AddLink
1339
1340 Takes a paramhash of Type and one of Base or Target. Adds that link to this object.
1341
1342 Returns C<link id>, C<message> and C<exist> flag.
1343
1344
1345 =cut
1346
1347 sub _AddLink {
1348     my $self = shift;
1349     my %args = ( Target => '',
1350                  Base   => '',
1351                  Type   => '',
1352                  Silent => undef,
1353                  @_ );
1354
1355
1356     # Remote_link is the URI of the object that is not this ticket
1357     my $remote_link;
1358     my $direction;
1359
1360     if ( $args{'Base'} and $args{'Target'} ) {
1361         $RT::Logger->debug( "$self tried to create a link. both base and target were specified" );
1362         return ( 0, $self->loc("Can't specifiy both base and target") );
1363     }
1364     elsif ( $args{'Base'} ) {
1365         $args{'Target'} = $self->URI();
1366         $remote_link    = $args{'Base'};
1367         $direction      = 'Target';
1368     }
1369     elsif ( $args{'Target'} ) {
1370         $args{'Base'} = $self->URI();
1371         $remote_link  = $args{'Target'};
1372         $direction    = 'Base';
1373     }
1374     else {
1375         return ( 0, $self->loc('Either base or target must be specified') );
1376     }
1377
1378     # Check if the link already exists - we don't want duplicates
1379     use RT::Link;
1380     my $old_link = RT::Link->new( $self->CurrentUser );
1381     $old_link->LoadByParams( Base   => $args{'Base'},
1382                              Type   => $args{'Type'},
1383                              Target => $args{'Target'} );
1384     if ( $old_link->Id ) {
1385         $RT::Logger->debug("$self Somebody tried to duplicate a link");
1386         return ( $old_link->id, $self->loc("Link already exists"), 1 );
1387     }
1388
1389     # }}}
1390
1391
1392     # Storing the link in the DB.
1393     my $link = RT::Link->new( $self->CurrentUser );
1394     my ($linkid, $linkmsg) = $link->Create( Target => $args{Target},
1395                                   Base   => $args{Base},
1396                                   Type   => $args{Type} );
1397
1398     unless ($linkid) {
1399         $RT::Logger->error("Link could not be created: ".$linkmsg);
1400         return ( 0, $self->loc("Link could not be created") );
1401     }
1402
1403     my $basetext = $self->FormatLink(Object => $link->BaseObj,
1404                                      FallBack => $args{Base});
1405     my $targettext = $self->FormatLink(Object => $link->TargetObj,
1406                                        FallBack => $args{Target});
1407     my $typetext = $self->FormatType(Type => $args{Type});
1408     my $TransString =
1409       "$basetext $typetext $targettext.";
1410     return ( $linkid, $TransString ) ;
1411 }
1412
1413
1414
1415 =head2 _DeleteLink
1416
1417 Delete a link. takes a paramhash of Base, Target and Type.
1418 Either Base or Target must be null. The null value will
1419 be replaced with this ticket\'s id
1420
1421 =cut
1422
1423 sub _DeleteLink {
1424     my $self = shift;
1425     my %args = (
1426         Base   => undef,
1427         Target => undef,
1428         Type   => undef,
1429         @_
1430     );
1431
1432     #we want one of base and target. we don't care which
1433     #but we only want _one_
1434
1435     my $direction;
1436     my $remote_link;
1437
1438     if ( $args{'Base'} and $args{'Target'} ) {
1439         $RT::Logger->debug("$self ->_DeleteLink. got both Base and Target");
1440         return ( 0, $self->loc("Can't specifiy both base and target") );
1441     }
1442     elsif ( $args{'Base'} ) {
1443         $args{'Target'} = $self->URI();
1444         $remote_link = $args{'Base'};
1445         $direction = 'Target';
1446     }
1447     elsif ( $args{'Target'} ) {
1448         $args{'Base'} = $self->URI();
1449         $remote_link = $args{'Target'};
1450         $direction='Base';
1451     }
1452     else {
1453         $RT::Logger->error("Base or Target must be specified");
1454         return ( 0, $self->loc('Either base or target must be specified') );
1455     }
1456
1457     my $link = RT::Link->new( $self->CurrentUser );
1458     $RT::Logger->debug( "Trying to load link: " . $args{'Base'} . " " . $args{'Type'} . " " . $args{'Target'} );
1459
1460
1461     $link->LoadByParams( Base=> $args{'Base'}, Type=> $args{'Type'}, Target=>  $args{'Target'} );
1462     #it's a real link.
1463
1464     if ( $link->id ) {
1465         my $basetext = $self->FormatLink(Object => $link->BaseObj,
1466                                      FallBack => $args{Base});
1467         my $targettext = $self->FormatLink(Object => $link->TargetObj,
1468                                        FallBack => $args{Target});
1469         my $typetext = $self->FormatType(Type => $args{Type});
1470         my $linkid = $link->id;
1471         $link->Delete();
1472         my $TransString = "$basetext no longer $typetext $targettext.";
1473         return ( 1, $TransString);
1474     }
1475
1476     #if it's not a link we can find
1477     else {
1478         $RT::Logger->debug("Couldn't find that link");
1479         return ( 0, $self->loc("Link not found") );
1480     }
1481 }
1482
1483
1484
1485
1486
1487 =head2 _NewTransaction  PARAMHASH
1488
1489 Private function to create a new RT::Transaction object for this ticket update
1490
1491 =cut
1492
1493 sub _NewTransaction {
1494     my $self = shift;
1495     my %args = (
1496         TimeTaken => undef,
1497         Type      => undef,
1498         OldValue  => undef,
1499         NewValue  => undef,
1500         OldReference  => undef,
1501         NewReference  => undef,
1502         ReferenceType => undef,
1503         Data      => undef,
1504         Field     => undef,
1505         MIMEObj   => undef,
1506         ActivateScrips => 1,
1507         CommitScrips => 1,
1508         SquelchMailTo => undef,
1509         CustomFields => {},
1510         @_
1511     );
1512
1513     my $old_ref = $args{'OldReference'};
1514     my $new_ref = $args{'NewReference'};
1515     my $ref_type = $args{'ReferenceType'};
1516     if ($old_ref or $new_ref) {
1517         $ref_type ||= ref($old_ref) || ref($new_ref);
1518         if (!$ref_type) {
1519             $RT::Logger->error("Reference type not specified for transaction");
1520             return;
1521         }
1522         $old_ref = $old_ref->Id if ref($old_ref);
1523         $new_ref = $new_ref->Id if ref($new_ref);
1524     }
1525
1526     require RT::Transaction;
1527     my $trans = RT::Transaction->new( $self->CurrentUser );
1528     my ( $transaction, $msg ) = $trans->Create(
1529         ObjectId  => $self->Id,
1530         ObjectType => ref($self),
1531         TimeTaken => $args{'TimeTaken'},
1532         Type      => $args{'Type'},
1533         Data      => $args{'Data'},
1534         Field     => $args{'Field'},
1535         NewValue  => $args{'NewValue'},
1536         OldValue  => $args{'OldValue'},
1537         NewReference  => $new_ref,
1538         OldReference  => $old_ref,
1539         ReferenceType => $ref_type,
1540         MIMEObj   => $args{'MIMEObj'},
1541         ActivateScrips => $args{'ActivateScrips'},
1542         CommitScrips => $args{'CommitScrips'},
1543         SquelchMailTo => $args{'SquelchMailTo'},
1544         CustomFields => $args{'CustomFields'},
1545     );
1546
1547     # Rationalize the object since we may have done things to it during the caching.
1548     $self->Load($self->Id);
1549
1550     $RT::Logger->warning($msg) unless $transaction;
1551
1552     $self->_SetLastUpdated;
1553
1554     if ( defined $args{'TimeTaken'} and $self->can('_UpdateTimeTaken')) {
1555         $self->_UpdateTimeTaken( $args{'TimeTaken'} );
1556     }
1557     if ( RT->Config->Get('UseTransactionBatch') and $transaction ) {
1558             push @{$self->{_TransactionBatch}}, $trans if $args{'CommitScrips'};
1559     }
1560     return ( $transaction, $msg, $trans );
1561 }
1562
1563
1564
1565 =head2 Transactions
1566
1567   Returns an RT::Transactions object of all transactions on this record object
1568
1569 =cut
1570
1571 sub Transactions {
1572     my $self = shift;
1573
1574     use RT::Transactions;
1575     my $transactions = RT::Transactions->new( $self->CurrentUser );
1576
1577     #If the user has no rights, return an empty object
1578     $transactions->Limit(
1579         FIELD => 'ObjectId',
1580         VALUE => $self->id,
1581     );
1582     $transactions->Limit(
1583         FIELD => 'ObjectType',
1584         VALUE => ref($self),
1585     );
1586
1587     return ($transactions);
1588 }
1589
1590 #
1591
1592 sub CustomFields {
1593     my $self = shift;
1594     my $cfs  = RT::CustomFields->new( $self->CurrentUser );
1595
1596     $cfs->SetContextObject( $self );
1597     # XXX handle multiple types properly
1598     $cfs->LimitToLookupType( $self->CustomFieldLookupType );
1599     $cfs->LimitToGlobalOrObjectId(
1600         $self->_LookupId( $self->CustomFieldLookupType )
1601     );
1602     $cfs->ApplySortOrder;
1603
1604     return $cfs;
1605 }
1606
1607 # TODO: This _only_ works for RT::Class classes. it doesn't work, for example,
1608 # for RT::IR classes.
1609
1610 sub _LookupId {
1611     my $self = shift;
1612     my $lookup = shift;
1613     my @classes = ($lookup =~ /RT::(\w+)-/g);
1614
1615     my $object = $self;
1616     foreach my $class (reverse @classes) {
1617         my $method = "${class}Obj";
1618         $object = $object->$method;
1619     }
1620
1621     return $object->Id;
1622 }
1623
1624
1625 =head2 CustomFieldLookupType
1626
1627 Returns the path RT uses to figure out which custom fields apply to this object.
1628
1629 =cut
1630
1631 sub CustomFieldLookupType {
1632     my $self = shift;
1633     return ref($self);
1634 }
1635
1636
1637 =head2 AddCustomFieldValue { Field => FIELD, Value => VALUE }
1638
1639 VALUE should be a string. FIELD can be any identifier of a CustomField
1640 supported by L</LoadCustomFieldByIdentifier> method.
1641
1642 Adds VALUE as a value of CustomField FIELD. If this is a single-value custom field,
1643 deletes the old value.
1644 If VALUE is not a valid value for the custom field, returns
1645 (0, 'Error message' ) otherwise, returns ($id, 'Success Message') where
1646 $id is ID of created L<ObjectCustomFieldValue> object.
1647
1648 =cut
1649
1650 sub AddCustomFieldValue {
1651     my $self = shift;
1652     $self->_AddCustomFieldValue(@_);
1653 }
1654
1655 sub _AddCustomFieldValue {
1656     my $self = shift;
1657     my %args = (
1658         Field             => undef,
1659         Value             => undef,
1660         LargeContent      => undef,
1661         ContentType       => undef,
1662         RecordTransaction => 1,
1663         @_
1664     );
1665
1666     my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
1667     unless ( $cf->Id ) {
1668         return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
1669     }
1670
1671     my $OCFs = $self->CustomFields;
1672     $OCFs->Limit( FIELD => 'id', VALUE => $cf->Id );
1673     unless ( $OCFs->Count ) {
1674         return (
1675             0,
1676             $self->loc(
1677                 "Custom field [_1] does not apply to this object",
1678                 $args{'Field'}
1679             )
1680         );
1681     }
1682
1683     # empty string is not correct value of any CF, so undef it
1684     foreach ( qw(Value LargeContent) ) {
1685         $args{ $_ } = undef if defined $args{ $_ } && !length $args{ $_ };
1686     }
1687
1688     unless ( $cf->ValidateValue( $args{'Value'} ) ) {
1689         return ( 0, $self->loc("Invalid value for custom field") );
1690     }
1691
1692     # If the custom field only accepts a certain # of values, delete the existing
1693     # value and record a "changed from foo to bar" transaction
1694     unless ( $cf->UnlimitedValues ) {
1695
1696         # Load up a ObjectCustomFieldValues object for this custom field and this ticket
1697         my $values = $cf->ValuesForObject($self);
1698
1699         # We need to whack any old values here.  In most cases, the custom field should
1700         # only have one value to delete.  In the pathalogical case, this custom field
1701         # used to be a multiple and we have many values to whack....
1702         my $cf_values = $values->Count;
1703
1704         if ( $cf_values > $cf->MaxValues ) {
1705             my $i = 0;   #We want to delete all but the max we can currently have , so we can then
1706                  # execute the same code to "change" the value from old to new
1707             while ( my $value = $values->Next ) {
1708                 $i++;
1709                 if ( $i < $cf_values ) {
1710                     my ( $val, $msg ) = $cf->DeleteValueForObject(
1711                         Object  => $self,
1712                         Content => $value->Content
1713                     );
1714                     unless ($val) {
1715                         return ( 0, $msg );
1716                     }
1717                     my ( $TransactionId, $Msg, $TransactionObj ) =
1718                       $self->_NewTransaction(
1719                         Type         => 'CustomField',
1720                         Field        => $cf->Id,
1721                         OldReference => $value,
1722                       );
1723                 }
1724             }
1725             $values->RedoSearch if $i; # redo search if have deleted at least one value
1726         }
1727
1728         my ( $old_value, $old_content );
1729         if ( $old_value = $values->First ) {
1730             $old_content = $old_value->Content;
1731             $old_content = undef if defined $old_content && !length $old_content;
1732
1733             my $is_the_same = 1;
1734             if ( defined $args{'Value'} ) {
1735                 $is_the_same = 0 unless defined $old_content
1736                     && lc $old_content eq lc $args{'Value'};
1737             } else {
1738                 $is_the_same = 0 if defined $old_content;
1739             }
1740             if ( $is_the_same ) {
1741                 my $old_content = $old_value->LargeContent;
1742                 if ( defined $args{'LargeContent'} ) {
1743                     $is_the_same = 0 unless defined $old_content
1744                         && $old_content eq $args{'LargeContent'};
1745                 } else {
1746                     $is_the_same = 0 if defined $old_content;
1747                 }
1748             }
1749
1750             return $old_value->id if $is_the_same;
1751         }
1752
1753         my ( $new_value_id, $value_msg ) = $cf->AddValueForObject(
1754             Object       => $self,
1755             Content      => $args{'Value'},
1756             LargeContent => $args{'LargeContent'},
1757             ContentType  => $args{'ContentType'},
1758         );
1759
1760         unless ( $new_value_id ) {
1761             return ( 0, $self->loc( "Could not add new custom field value: [_1]", $value_msg ) );
1762         }
1763
1764         my $new_value = RT::ObjectCustomFieldValue->new( $self->CurrentUser );
1765         $new_value->Load( $new_value_id );
1766
1767         # now that adding the new value was successful, delete the old one
1768         if ( $old_value ) {
1769             my ( $val, $msg ) = $old_value->Delete();
1770             return ( 0, $msg ) unless $val;
1771         }
1772
1773         if ( $args{'RecordTransaction'} ) {
1774             my ( $TransactionId, $Msg, $TransactionObj ) =
1775               $self->_NewTransaction(
1776                 Type         => 'CustomField',
1777                 Field        => $cf->Id,
1778                 OldReference => $old_value,
1779                 NewReference => $new_value,
1780               );
1781         }
1782
1783         my $new_content = $new_value->Content;
1784
1785         # For datetime, we need to display them in "human" format in result message
1786         #XXX TODO how about date without time?
1787         if ($cf->Type eq 'DateTime') {
1788             my $DateObj = RT::Date->new( $self->CurrentUser );
1789             $DateObj->Set(
1790                 Format => 'ISO',
1791                 Value  => $new_content,
1792             );
1793             $new_content = $DateObj->AsString;
1794
1795             if ( defined $old_content && length $old_content ) {
1796                 $DateObj->Set(
1797                     Format => 'ISO',
1798                     Value  => $old_content,
1799                 );
1800                 $old_content = $DateObj->AsString;
1801             }
1802         }
1803
1804         unless ( defined $old_content && length $old_content ) {
1805             return ( $new_value_id, $self->loc( "[_1] [_2] added", $cf->Name, $new_content ));
1806         }
1807         elsif ( !defined $new_content || !length $new_content ) {
1808             return ( $new_value_id,
1809                 $self->loc( "[_1] [_2] deleted", $cf->Name, $old_content ) );
1810         }
1811         else {
1812             return ( $new_value_id, $self->loc( "[_1] [_2] changed to [_3]", $cf->Name, $old_content, $new_content));
1813         }
1814
1815     }
1816
1817     # otherwise, just add a new value and record "new value added"
1818     else {
1819         my ($new_value_id, $msg) = $cf->AddValueForObject(
1820             Object       => $self,
1821             Content      => $args{'Value'},
1822             LargeContent => $args{'LargeContent'},
1823             ContentType  => $args{'ContentType'},
1824         );
1825
1826         unless ( $new_value_id ) {
1827             return ( 0, $self->loc( "Could not add new custom field value: [_1]", $msg ) );
1828         }
1829         if ( $args{'RecordTransaction'} ) {
1830             my ( $tid, $msg ) = $self->_NewTransaction(
1831                 Type          => 'CustomField',
1832                 Field         => $cf->Id,
1833                 NewReference  => $new_value_id,
1834                 ReferenceType => 'RT::ObjectCustomFieldValue',
1835             );
1836             unless ( $tid ) {
1837                 return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $msg ) );
1838             }
1839         }
1840         return ( $new_value_id, $self->loc( "[_1] added as a value for [_2]", $args{'Value'}, $cf->Name ) );
1841     }
1842 }
1843
1844
1845
1846 =head2 DeleteCustomFieldValue { Field => FIELD, Value => VALUE }
1847
1848 Deletes VALUE as a value of CustomField FIELD.
1849
1850 VALUE can be a string, a CustomFieldValue or a ObjectCustomFieldValue.
1851
1852 If VALUE is not a valid value for the custom field, returns
1853 (0, 'Error message' ) otherwise, returns (1, 'Success Message')
1854
1855 =cut
1856
1857 sub DeleteCustomFieldValue {
1858     my $self = shift;
1859     my %args = (
1860         Field   => undef,
1861         Value   => undef,
1862         ValueId => undef,
1863         @_
1864     );
1865
1866     my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
1867     unless ( $cf->Id ) {
1868         return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
1869     }
1870
1871     my ( $val, $msg ) = $cf->DeleteValueForObject(
1872         Object  => $self,
1873         Id      => $args{'ValueId'},
1874         Content => $args{'Value'},
1875     );
1876     unless ($val) {
1877         return ( 0, $msg );
1878     }
1879
1880     my ( $TransactionId, $Msg, $TransactionObj ) = $self->_NewTransaction(
1881         Type          => 'CustomField',
1882         Field         => $cf->Id,
1883         OldReference  => $val,
1884         ReferenceType => 'RT::ObjectCustomFieldValue',
1885     );
1886     unless ($TransactionId) {
1887         return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $Msg ) );
1888     }
1889
1890     my $old_value = $TransactionObj->OldValue;
1891     # For datetime, we need to display them in "human" format in result message
1892     if ( $cf->Type eq 'DateTime' ) {
1893         my $DateObj = RT::Date->new( $self->CurrentUser );
1894         $DateObj->Set(
1895             Format => 'ISO',
1896             Value  => $old_value,
1897         );
1898         $old_value = $DateObj->AsString;
1899     }
1900     return (
1901         $TransactionId,
1902         $self->loc(
1903             "[_1] is no longer a value for custom field [_2]",
1904             $old_value, $cf->Name
1905         )
1906     );
1907 }
1908
1909
1910
1911 =head2 FirstCustomFieldValue FIELD
1912
1913 Return the content of the first value of CustomField FIELD for this ticket
1914 Takes a field id or name
1915
1916 =cut
1917
1918 sub FirstCustomFieldValue {
1919     my $self = shift;
1920     my $field = shift;
1921
1922     my $values = $self->CustomFieldValues( $field );
1923     return undef unless my $first = $values->First;
1924     return $first->Content;
1925 }
1926
1927 =head2 CustomFieldValuesAsString FIELD
1928
1929 Return the content of the CustomField FIELD for this ticket.
1930 If this is a multi-value custom field, values will be joined with newlines.
1931
1932 Takes a field id or name as the first argument
1933
1934 Takes an optional Separator => "," second and third argument
1935 if you want to join the values using something other than a newline
1936
1937 =cut
1938
1939 sub CustomFieldValuesAsString {
1940     my $self  = shift;
1941     my $field = shift;
1942     my %args  = @_;
1943     my $separator = $args{Separator} || "\n";
1944
1945     my $values = $self->CustomFieldValues( $field );
1946     return join ($separator, grep { defined $_ }
1947                  map { $_->Content } @{$values->ItemsArrayRef});
1948 }
1949
1950
1951
1952 =head2 CustomFieldValues FIELD
1953
1954 Return a ObjectCustomFieldValues object of all values of the CustomField whose
1955 id or Name is FIELD for this record.
1956
1957 Returns an RT::ObjectCustomFieldValues object
1958
1959 =cut
1960
1961 sub CustomFieldValues {
1962     my $self  = shift;
1963     my $field = shift;
1964
1965     if ( $field ) {
1966         my $cf = $self->LoadCustomFieldByIdentifier( $field );
1967
1968         # we were asked to search on a custom field we couldn't find
1969         unless ( $cf->id ) {
1970             $RT::Logger->warning("Couldn't load custom field by '$field' identifier");
1971             return RT::ObjectCustomFieldValues->new( $self->CurrentUser );
1972         }
1973         return ( $cf->ValuesForObject($self) );
1974     }
1975
1976     # we're not limiting to a specific custom field;
1977     my $ocfs = RT::ObjectCustomFieldValues->new( $self->CurrentUser );
1978     $ocfs->LimitToObject( $self );
1979     return $ocfs;
1980 }
1981
1982 =head2 LoadCustomFieldByIdentifier IDENTIFER
1983
1984 Find the custom field has id or name IDENTIFIER for this object.
1985
1986 If no valid field is found, returns an empty RT::CustomField object.
1987
1988 =cut
1989
1990 sub LoadCustomFieldByIdentifier {
1991     my $self = shift;
1992     my $field = shift;
1993
1994     my $cf;
1995     if ( UNIVERSAL::isa( $field, "RT::CustomField" ) ) {
1996         $cf = RT::CustomField->new($self->CurrentUser);
1997         $cf->SetContextObject( $self );
1998         $cf->LoadById( $field->id );
1999     }
2000     elsif ($field =~ /^\d+$/) {
2001         $cf = RT::CustomField->new($self->CurrentUser);
2002         $cf->SetContextObject( $self );
2003         $cf->LoadById($field);
2004     } else {
2005
2006         my $cfs = $self->CustomFields($self->CurrentUser);
2007         $cfs->SetContextObject( $self );
2008         $cfs->Limit(FIELD => 'Name', VALUE => $field, CASESENSITIVE => 0);
2009         $cf = $cfs->First || RT::CustomField->new($self->CurrentUser);
2010     }
2011     return $cf;
2012 }
2013
2014 sub ACLEquivalenceObjects { }
2015
2016 sub BasicColumns { }
2017
2018 sub WikiBase {
2019     return RT->Config->Get('WebPath'). "/index.html?q=";
2020 }
2021
2022 RT::Base->_ImportOverlays();
2023
2024 1;