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