lib/RT/Record.pm

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