rt/lib/RT/Record.pm

   1 # BEGIN BPS TAGGED BLOCK {{{
   2 #
   3 # COPYRIGHT:
   4 #
   5 # This software is Copyright (c) 1996-2019 Best Practical Solutions, LLC
   6 #                                          <sales@bestpractical.com>
   7 #
   8 # (Except where explicitly superseded by other copyright notices)
   9 #
  10 #
  11 # LICENSE:
  12 #
  13 # This work is made available to you under the terms of Version 2 of
  14 # the GNU General Public License. A copy of that license should have
  15 # been provided with this software, but in any event can be snarfed
  16 # from www.gnu.org.
  17 #
  18 # This work is distributed in the hope that it will be useful, but
  19 # WITHOUT ANY WARRANTY; without even the implied warranty of
  20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 # General Public License for more details.
  22 #
  23 # You should have received a copy of the GNU General Public License
  24 # along with this program; if not, write to the Free Software
  25 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  26 # 02110-1301 or visit their web page on the internet at
  27 # http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
  28 #
  29 #
  30 # CONTRIBUTION SUBMISSION POLICY:
  31 #
  32 # (The following paragraph is not intended to limit the rights granted
  33 # to you to modify and distribute this software under the terms of
  34 # the GNU General Public License and is only of importance to you if
  35 # you choose to contribute your changes and enhancements to the
  36 # community by submitting them to Best Practical Solutions, LLC.)
  37 #
  38 # By intentionally submitting any modifications, corrections or
  39 # derivatives to this work, or any other work intended for use with
  40 # Request Tracker, to Best Practical Solutions, LLC, you confirm that
  41 # you are the copyright holder for those contributions and you grant
  42 # Best Practical Solutions,  LLC a nonexclusive, worldwide, irrevocable,
  43 # royalty-free, perpetual, license to use, copy, create derivative
  44 # works based on those contributions, and sublicense and distribute
  45 # those contributions and any derivatives thereof.
  46 #
  47 # END BPS TAGGED BLOCK }}}
  48
  49 =head1 NAME
  50
  51   RT::Record - Base class for RT record objects
  52
  53 =head1 SYNOPSIS
  54
  55
  56 =head1 DESCRIPTION
  57
  58
  59
  60 =head1 METHODS
  61
  62 =cut
  63
  64 package RT::Record;
  65
  66 use strict;
  67 use warnings;
  68
  69 use RT;
  70 use base RT->Config->Get('RecordBaseClass');
  71 use base 'RT::Base';
  72
  73 require RT::Date;
  74 require RT::User;
  75 require RT::Attributes;
  76 require RT::Transactions;
  77 require RT::Link;
  78 use RT::Shredder::Dependencies;
  79 use RT::Shredder::Constants;
  80 use RT::Shredder::Exceptions;
  81
  82 our $_TABLE_ATTR = { };
  83 use base RT->Config->Get('RecordBaseClass');
  84 use base 'RT::Base';
  85
  86
  87 sub _Init {
  88     my $self = shift;
  89     $self->_BuildTableAttributes unless ($_TABLE_ATTR->{ref($self)});
  90     $self->CurrentUser(@_);
  91 }
  92
  93
  94
  95 =head2 _PrimaryKeys
  96
  97 The primary keys for RT classes is 'id'
  98
  99 =cut
 100
 101 sub _PrimaryKeys { return ['id'] }
 102 # short circuit many, many thousands of calls from searchbuilder
 103 sub _PrimaryKey { 'id' }
 104
 105 =head2 Id
 106
 107 Override L<DBIx::SearchBuilder/Id> to avoid a few lookups RT doesn't do
 108 on a very common codepath
 109
 110 C<id> is an alias to C<Id> and is the preferred way to call this method.
 111
 112 =cut
 113
 114 sub Id {
 115     return shift->{'values'}->{id};
 116 }
 117
 118 *id = \&Id;
 119
 120 =head2 Delete
 121
 122 Delete this record object from the database.
 123
 124 =cut
 125
 126 sub Delete {
 127     my $self = shift;
 128     my ($rv) = $self->SUPER::Delete;
 129     if ($rv) {
 130         return ($rv, $self->loc("Object deleted"));
 131     } else {
 132
 133         return(0, $self->loc("Object could not be deleted"))
 134     }
 135 }
 136
 137 =head2 RecordType
 138
 139 Returns a string which is this record's type. It's not localized and by
 140 default last part (everything after last ::) of class name is returned.
 141
 142 =cut
 143
 144 sub RecordType {
 145     my $res = ref($_[0]) || $_[0];
 146     $res =~ s/.*:://;
 147     return $res;
 148 }
 149
 150 =head2 ObjectTypeStr
 151
 152 DEPRECATED. Stays here for backwards. Returns localized L</RecordType>.
 153
 154 =cut
 155
 156 # we deprecate because of:
 157 # * ObjectType is used in several classes with ObjectId to store
 158 #   records of different types, for example transactions use those
 159 #   and it's unclear what this method should return 'Transaction'
 160 #   or type of referenced record
 161 # * returning localized thing is not good idea
 162
 163 sub ObjectTypeStr {
 164     my $self = shift;
 165     RT->Deprecated(
 166         Remove => "4.4",
 167         Instead => "RecordType",
 168     );
 169     return $self->loc( $self->RecordType( @_ ) );
 170 }
 171
 172 =head2 Attributes
 173
 174 Return this object's attributes as an RT::Attributes object
 175
 176 =cut
 177
 178 sub Attributes {
 179     my $self = shift;
 180     unless ($self->{'attributes'}) {
 181         $self->{'attributes'} = RT::Attributes->new($self->CurrentUser);
 182         $self->{'attributes'}->LimitToObject($self);
 183         $self->{'attributes'}->OrderByCols({FIELD => 'id'});
 184     }
 185     return ($self->{'attributes'});
 186 }
 187
 188
 189 =head2 AddAttribute { Name, Description, Content }
 190
 191 Adds a new attribute for this object.
 192
 193 =cut
 194
 195 sub AddAttribute {
 196     my $self = shift;
 197     my %args = ( Name        => undef,
 198                  Description => undef,
 199                  Content     => undef,
 200                  @_ );
 201
 202     my $attr = RT::Attribute->new( $self->CurrentUser );
 203     my ( $id, $msg ) = $attr->Create(
 204                                       Object    => $self,
 205                                       Name        => $args{'Name'},
 206                                       Description => $args{'Description'},
 207                                       Content     => $args{'Content'} );
 208
 209
 210     # XXX TODO: Why won't RedoSearch work here?
 211     $self->Attributes->_DoSearch;
 212
 213     return ($id, $msg);
 214 }
 215
 216
 217 =head2 SetAttribute { Name, Description, Content }
 218
 219 Like AddAttribute, but replaces all existing attributes with the same Name.
 220
 221 =cut
 222
 223 sub SetAttribute {
 224     my $self = shift;
 225     my %args = ( Name        => undef,
 226                  Description => undef,
 227                  Content     => undef,
 228                  @_ );
 229
 230     my @AttributeObjs = $self->Attributes->Named( $args{'Name'} )
 231         or return $self->AddAttribute( %args );
 232
 233     my $AttributeObj = pop( @AttributeObjs );
 234     $_->Delete foreach @AttributeObjs;
 235
 236     $AttributeObj->SetDescription( $args{'Description'} );
 237     $AttributeObj->SetContent( $args{'Content'} );
 238
 239     $self->Attributes->RedoSearch;
 240     return 1;
 241 }
 242
 243 =head2 DeleteAttribute NAME
 244
 245 Deletes all attributes with the matching name for this object.
 246
 247 =cut
 248
 249 sub DeleteAttribute {
 250     my $self = shift;
 251     my $name = shift;
 252     my ($val,$msg) =  $self->Attributes->DeleteEntry( Name => $name );
 253     $self->ClearAttributes;
 254     return ($val,$msg);
 255 }
 256
 257 =head2 FirstAttribute NAME
 258
 259 Returns the first attribute with the matching name for this object (as an
 260 L<RT::Attribute> object), or C<undef> if no such attributes exist.
 261 If there is more than one attribute with the matching name on the
 262 object, the first value that was set is returned.
 263
 264 =cut
 265
 266 sub FirstAttribute {
 267     my $self = shift;
 268     my $name = shift;
 269     return ($self->Attributes->Named( $name ))[0];
 270 }
 271
 272
 273 sub ClearAttributes {
 274     my $self = shift;
 275     delete $self->{'attributes'};
 276
 277 }
 278
 279 sub _Handle { return $RT::Handle }
 280
 281
 282
 283 =head2  Create PARAMHASH
 284
 285 Takes a PARAMHASH of Column -> Value pairs.
 286 If any Column has a Validate$PARAMNAME subroutine defined and the
 287 value provided doesn't pass validation, this routine returns
 288 an error.
 289
 290 If this object's table has any of the following atetributes defined as
 291 'Auto', this routine will automatically fill in their values.
 292
 293 =over
 294
 295 =item Created
 296
 297 =item Creator
 298
 299 =item LastUpdated
 300
 301 =item LastUpdatedBy
 302
 303 =back
 304
 305 =cut
 306
 307 sub Create {
 308     my $self    = shift;
 309     my %attribs = (@_);
 310     foreach my $key ( keys %attribs ) {
 311         if (my $method = $self->can("Validate$key")) {
 312         if (! $method->( $self, $attribs{$key} ) ) {
 313             if (wantarray) {
 314                 return ( 0, $self->loc('Invalid value for [_1]', $key) );
 315             }
 316             else {
 317                 return (0);
 318             }
 319         }
 320         }
 321     }
 322
 323
 324
 325     my ($sec,$min,$hour,$mday,$mon,$year,$wday,$ydaym,$isdst,$offset) = gmtime();
 326
 327     my $now_iso =
 328      sprintf("%04d-%02d-%02d %02d:%02d:%02d", ($year+1900), ($mon+1), $mday, $hour, $min, $sec);
 329
 330     $attribs{'Created'} = $now_iso if ( $self->_Accessible( 'Created', 'auto' ) && !$attribs{'Created'});
 331
 332     if ($self->_Accessible( 'Creator', 'auto' ) && !$attribs{'Creator'}) {
 333          $attribs{'Creator'} = $self->CurrentUser->id || '0';
 334     }
 335     $attribs{'LastUpdated'} = $now_iso
 336       if ( $self->_Accessible( 'LastUpdated', 'auto' ) && !$attribs{'LastUpdated'});
 337
 338     $attribs{'LastUpdatedBy'} = $self->CurrentUser->id || '0'
 339       if ( $self->_Accessible( 'LastUpdatedBy', 'auto' ) && !$attribs{'LastUpdatedBy'});
 340
 341     my $id = $self->SUPER::Create(%attribs);
 342     if ( UNIVERSAL::isa( $id, 'Class::ReturnValue' ) ) {
 343         if ( $id->errno ) {
 344             if (wantarray) {
 345                 return ( 0,
 346                     $self->loc( "Internal Error: [_1]", $id->{error_message} ) );
 347             }
 348             else {
 349                 return (0);
 350             }
 351         }
 352     }
 353     # If the object was created in the database,
 354     # load it up now, so we're sure we get what the database
 355     # has.  Arguably, this should not be necessary, but there
 356     # isn't much we can do about it.
 357
 358    unless ($id) {
 359     if (wantarray) {
 360         return ( $id, $self->loc('Object could not be created') );
 361     }
 362     else {
 363         return ($id);
 364     }
 365
 366    }
 367
 368     if  (UNIVERSAL::isa('errno',$id)) {
 369         return(undef);
 370     }
 371
 372     $self->Load($id) if ($id);
 373
 374
 375
 376     if (wantarray) {
 377         return ( $id, $self->loc('Object created') );
 378     }
 379     else {
 380         return ($id);
 381     }
 382
 383 }
 384
 385
 386
 387 =head2 LoadByCols
 388
 389 Override DBIx::SearchBuilder::LoadByCols to do case-insensitive loads if the
 390 DB is case sensitive
 391
 392 =cut
 393
 394 sub LoadByCols {
 395     my $self = shift;
 396
 397     # We don't want to hang onto this
 398     $self->ClearAttributes;
 399
 400     unless ( $self->_Handle->CaseSensitive ) {
 401         my ( $ret, $msg ) = $self->SUPER::LoadByCols( @_ );
 402         return wantarray ? ( $ret, $msg ) : $ret;
 403     }
 404
 405     # If this database is case sensitive we need to uncase objects for
 406     # explicit loading
 407     my %hash = (@_);
 408     foreach my $key ( keys %hash ) {
 409
 410         # If we've been passed an empty value, we can't do the lookup.
 411         # We don't need to explicitly downcase integers or an id.
 412         if ( $key ne 'id' && defined $hash{ $key } && $hash{ $key } !~ /^\d+$/ ) {
 413             my ($op, $val, $func);
 414             ($key, $op, $val, $func) =
 415                 $self->_Handle->_MakeClauseCaseInsensitive( $key, '=', delete $hash{ $key } );
 416             $hash{$key}->{operator} = $op;
 417             $hash{$key}->{value}    = $val;
 418             $hash{$key}->{function} = $func;
 419         }
 420     }
 421     my ( $ret, $msg ) = $self->SUPER::LoadByCols( %hash );
 422     return wantarray ? ( $ret, $msg ) : $ret;
 423 }
 424
 425
 426
 427 # There is room for optimizations in most of those subs:
 428
 429
 430 sub LastUpdatedObj {
 431     my $self = shift;
 432     my $obj  = RT::Date->new( $self->CurrentUser );
 433
 434     $obj->Set( Format => 'sql', Value => $self->LastUpdated );
 435     return $obj;
 436 }
 437
 438
 439
 440 sub CreatedObj {
 441     my $self = shift;
 442     my $obj  = RT::Date->new( $self->CurrentUser );
 443
 444     $obj->Set( Format => 'sql', Value => $self->Created );
 445
 446     return $obj;
 447 }
 448
 449
 450 # B<DEPRECATED> and will be removed in 4.4
 451 sub AgeAsString {
 452     my $self = shift;
 453     RT->Deprecated(
 454         Remove => "4.4",
 455         Instead => "->CreatedObj->AgeAsString",
 456     );
 457     return ( $self->CreatedObj->AgeAsString() );
 458 }
 459
 460 # B<DEPRECATED> and will be removed in 4.4
 461 sub LongSinceUpdateAsString {
 462     my $self = shift;
 463     RT->Deprecated(
 464         Remove => "4.4",
 465         Instead => "->LastUpdatedObj->AgeAsString",
 466     );
 467     if ( $self->LastUpdated ) {
 468         return ( $self->LastUpdatedObj->AgeAsString() );
 469     } else {
 470         return "never";
 471     }
 472 }
 473
 474 sub LastUpdatedAsString {
 475     my $self = shift;
 476     if ( $self->LastUpdated ) {
 477         return ( $self->LastUpdatedObj->AsString() );
 478     } else {
 479         return "never";
 480     }
 481 }
 482
 483 sub CreatedAsString {
 484     my $self = shift;
 485     return ( $self->CreatedObj->AsString() );
 486 }
 487
 488 sub _Set {
 489     my $self = shift;
 490
 491     my %args = (
 492         Field => undef,
 493         Value => undef,
 494         IsSQL => undef,
 495         @_
 496     );
 497
 498     #if the user is trying to modify the record
 499     # TODO: document _why_ this code is here
 500
 501     if ( ( !defined( $args{'Field'} ) ) || ( !defined( $args{'Value'} ) ) ) {
 502         $args{'Value'} = 0;
 503     }
 504
 505     my $old_val = $self->__Value($args{'Field'});
 506      $self->_SetLastUpdated();
 507     my $ret = $self->SUPER::_Set(
 508         Field => $args{'Field'},
 509         Value => $args{'Value'},
 510         IsSQL => $args{'IsSQL'}
 511     );
 512         my ($status, $msg) =  $ret->as_array();
 513
 514         # @values has two values, a status code and a message.
 515
 516     # $ret is a Class::ReturnValue object. as such, in a boolean context, it's a bool
 517     # we want to change the standard "success" message
 518     if ($status) {
 519         if ($self->SQLType( $args{'Field'}) =~ /text/) {
 520             $msg = $self->loc(
 521                 "[_1] updated",
 522                 $self->loc( $args{'Field'} ),
 523             );
 524         } else {
 525             $msg = $self->loc(
 526                 "[_1] changed from [_2] to [_3]",
 527                 $self->loc( $args{'Field'} ),
 528                 ( $old_val ? '"' . $old_val . '"' : $self->loc("(no value)") ),
 529                 '"' . $self->__Value( $args{'Field'}) . '"',
 530             );
 531         }
 532     } else {
 533         $msg = $self->CurrentUser->loc_fuzzy($msg);
 534     }
 535
 536     return wantarray ? ($status, $msg) : $ret;
 537 }
 538
 539
 540
 541 =head2 _SetLastUpdated
 542
 543 This routine updates the LastUpdated and LastUpdatedBy columns of the row in question
 544 It takes no options. Arguably, this is a bug
 545
 546 =cut
 547
 548 sub _SetLastUpdated {
 549     my $self = shift;
 550     my $now = RT::Date->new( $self->CurrentUser );
 551     $now->SetToNow();
 552
 553     if ( $self->_Accessible( 'LastUpdated', 'auto' ) ) {
 554         my ( $msg, $val ) = $self->__Set(
 555             Field => 'LastUpdated',
 556             Value => $now->ISO
 557         );
 558     }
 559     if ( $self->_Accessible( 'LastUpdatedBy', 'auto' ) ) {
 560         my ( $msg, $val ) = $self->__Set(
 561             Field => 'LastUpdatedBy',
 562             Value => $self->CurrentUser->id
 563         );
 564     }
 565 }
 566
 567
 568
 569 =head2 CreatorObj
 570
 571 Returns an RT::User object with the RT account of the creator of this row
 572
 573 =cut
 574
 575 sub CreatorObj {
 576     my $self = shift;
 577     unless ( exists $self->{'CreatorObj'} ) {
 578
 579         $self->{'CreatorObj'} = RT::User->new( $self->CurrentUser );
 580         $self->{'CreatorObj'}->Load( $self->Creator );
 581     }
 582     return ( $self->{'CreatorObj'} );
 583 }
 584
 585
 586
 587 =head2 LastUpdatedByObj
 588
 589   Returns an RT::User object of the last user to touch this object
 590
 591 =cut
 592
 593 sub LastUpdatedByObj {
 594     my $self = shift;
 595     unless ( exists $self->{LastUpdatedByObj} ) {
 596         $self->{'LastUpdatedByObj'} = RT::User->new( $self->CurrentUser );
 597         $self->{'LastUpdatedByObj'}->Load( $self->LastUpdatedBy );
 598     }
 599     return $self->{'LastUpdatedByObj'};
 600 }
 601
 602
 603
 604 =head2 URI
 605
 606 Returns this record's URI
 607
 608 =cut
 609
 610 sub URI {
 611     my $self = shift;
 612     my $uri = RT::URI::fsck_com_rt->new($self->CurrentUser);
 613     return($uri->URIForObject($self));
 614 }
 615
 616
 617 =head2 ValidateName NAME
 618
 619 Validate the name of the record we're creating. Mostly, just make sure it's not a numeric ID, which is invalid for Name
 620
 621 =cut
 622
 623 sub ValidateName {
 624     my $self = shift;
 625     my $value = shift;
 626     if (defined $value && $value=~ /^\d+$/) {
 627         return(0);
 628     } else  {
 629         return(1);
 630     }
 631 }
 632
 633
 634
 635 =head2 SQLType attribute
 636
 637 return the SQL type for the attribute 'attribute' as stored in _ClassAccessible
 638
 639 =cut
 640
 641 sub SQLType {
 642     my $self = shift;
 643     my $field = shift;
 644
 645     return ($self->_Accessible($field, 'type'));
 646
 647
 648 }
 649
 650 sub __Value {
 651     my $self  = shift;
 652     my $field = shift;
 653     my %args  = ( decode_utf8 => 1, @_ );
 654
 655     unless ($field) {
 656         $RT::Logger->error("__Value called with undef field");
 657     }
 658
 659     my $value = $self->SUPER::__Value($field);
 660     return $value if ref $value;
 661
 662     return undef if (!defined $value);
 663
 664     # Pg returns character columns as character strings; mysql and
 665     # sqlite return them as bytes.  While mysql can be made to return
 666     # characters, using the mysql_enable_utf8 flag, the "Content" column
 667     # is bytes on mysql and characters on Postgres, making true
 668     # consistency impossible.
 669     if ( $args{'decode_utf8'} ) {
 670         if ( !utf8::is_utf8($value) ) { # mysql/sqlite
 671             utf8::decode($value);
 672         }
 673     } else {
 674         if ( utf8::is_utf8($value) ) {
 675             utf8::encode($value);
 676         }
 677     }
 678
 679     return $value;
 680
 681 }
 682
 683 # Set up defaults for DBIx::SearchBuilder::Record::Cachable
 684
 685 sub _CacheConfig {
 686   {
 687      'cache_for_sec'  => 30,
 688   }
 689 }
 690
 691
 692
 693 sub _BuildTableAttributes {
 694     my $self = shift;
 695     my $class = ref($self) || $self;
 696
 697     my $attributes;
 698     if ( UNIVERSAL::can( $self, '_CoreAccessible' ) ) {
 699        $attributes = $self->_CoreAccessible();
 700     } elsif ( UNIVERSAL::can( $self, '_ClassAccessible' ) ) {
 701        $attributes = $self->_ClassAccessible();
 702
 703     }
 704
 705     foreach my $column (keys %$attributes) {
 706         foreach my $attr ( keys %{ $attributes->{$column} } ) {
 707             $_TABLE_ATTR->{$class}->{$column}->{$attr} = $attributes->{$column}->{$attr};
 708         }
 709     }
 710     foreach my $method ( qw(_OverlayAccessible _VendorAccessible _LocalAccessible) ) {
 711         next unless UNIVERSAL::can( $self, $method );
 712         $attributes = $self->$method();
 713
 714         foreach my $column ( keys %$attributes ) {
 715             foreach my $attr ( keys %{ $attributes->{$column} } ) {
 716                 $_TABLE_ATTR->{$class}->{$column}->{$attr} = $attributes->{$column}->{$attr};
 717             }
 718         }
 719     }
 720 }
 721
 722
 723 =head2 _ClassAccessible
 724
 725 Overrides the "core" _ClassAccessible using $_TABLE_ATTR. Behaves identical to the version in
 726 DBIx::SearchBuilder::Record
 727
 728 =cut
 729
 730 sub _ClassAccessible {
 731     my $self = shift;
 732     return $_TABLE_ATTR->{ref($self) || $self};
 733 }
 734
 735 =head2 _Accessible COLUMN ATTRIBUTE
 736
 737 returns the value of ATTRIBUTE for COLUMN
 738
 739
 740 =cut
 741
 742 sub _Accessible  {
 743   my $self = shift;
 744   my $column = shift;
 745   my $attribute = lc(shift);
 746
 747   my $class =  ref($self) || $self;
 748   $class->_BuildTableAttributes unless ($_TABLE_ATTR->{$class});
 749
 750   return 0 unless defined ($_TABLE_ATTR->{$class}->{$column});
 751   return $_TABLE_ATTR->{$class}->{$column}->{$attribute} || 0;
 752
 753 }
 754
 755 =head2 _EncodeLOB BODY MIME_TYPE FILENAME
 756
 757 Takes a potentially large attachment. Returns (ContentEncoding,
 758 EncodedBody, MimeType, Filename, NoteArgs) based on system configuration and
 759 selected database.  Returns a custom (short) text/plain message if
 760 DropLongAttachments causes an attachment to not be stored.
 761
 762 Encodes your data as base64 or Quoted-Printable as needed based on your
 763 Databases's restrictions and the UTF-8ness of the data being passed in.  Since
 764 we are storing in columns marked UTF8, we must ensure that binary data is
 765 encoded on databases which are strict.
 766
 767 This function expects to receive an octet string in order to properly
 768 evaluate and encode it.  It will return an octet string.
 769
 770 NoteArgs is currently used to indicate caller that the message is too long and
 771 is truncated or dropped. It's a hashref which is expected to be passed to
 772 L<RT::Record/_NewTransaction>.
 773
 774 =cut
 775
 776 sub _EncodeLOB {
 777     my $self = shift;
 778     my $Body = shift;
 779     my $MIMEType = shift || '';
 780     my $Filename = shift;
 781
 782     my $ContentEncoding = 'none';
 783     my $note_args;
 784
 785     RT::Util::assert_bytes( $Body );
 786
 787     #get the max attachment length from RT
 788     my $MaxSize = RT->Config->Get('MaxAttachmentSize');
 789
 790     #if the current attachment contains nulls and the
 791     #database doesn't support embedded nulls
 792
 793     if ( ( !$RT::Handle->BinarySafeBLOBs ) && ( $Body =~ /\x00/ ) ) {
 794
 795         # set a flag telling us to mimencode the attachment
 796         $ContentEncoding = 'base64';
 797
 798         #cut the max attchment size by 25% (for mime-encoding overhead.
 799         $RT::Logger->debug("Max size is $MaxSize");
 800         $MaxSize = $MaxSize * 3 / 4;
 801     # Some databases (postgres) can't handle non-utf8 data
 802     } elsif (    !$RT::Handle->BinarySafeBLOBs
 803               && $Body =~ /\P{ASCII}/
 804               && !Encode::is_utf8( $Body, 1 ) ) {
 805           $ContentEncoding = 'quoted-printable';
 806     }
 807
 808     #if the attachment is larger than the maximum size
 809     if ( ($MaxSize) and ( $MaxSize < length($Body) ) ) {
 810
 811         my $size = length $Body;
 812         # if we're supposed to truncate large attachments
 813         if (RT->Config->Get('TruncateLongAttachments')) {
 814
 815             $RT::Logger->info("$self: Truncated an attachment of size $size");
 816
 817             # truncate the attachment to that length.
 818             $Body = substr( $Body, 0, $MaxSize );
 819             $note_args = {
 820                 Type           => 'AttachmentTruncate',
 821                 Data           => $Filename,
 822                 OldValue       => $size,
 823                 NewValue       => $MaxSize,
 824                 ActivateScrips => 0,
 825             };
 826
 827         }
 828
 829         # elsif we're supposed to drop large attachments on the floor,
 830         elsif (RT->Config->Get('DropLongAttachments')) {
 831
 832             # drop the attachment on the floor
 833             $RT::Logger->info( "$self: Dropped an attachment of size $size" );
 834             $RT::Logger->info( "It started: " . substr( $Body, 0, 60 ) );
 835             $note_args = {
 836                 Type           => 'AttachmentDrop',
 837                 Data           => $Filename,
 838                 OldValue       => $size,
 839                 NewValue       => $MaxSize,
 840                 ActivateScrips => 0,
 841             };
 842             $Filename .= ".txt" if $Filename && $Filename !~ /\.txt$/;
 843             return ("none", "Large attachment dropped", "text/plain", $Filename, $note_args );
 844         }
 845     }
 846
 847     # if we need to mimencode the attachment
 848     if ( $ContentEncoding eq 'base64' ) {
 849         # base64 encode the attachment
 850         $Body = MIME::Base64::encode_base64($Body);
 851
 852     } elsif ($ContentEncoding eq 'quoted-printable') {
 853         $Body = MIME::QuotedPrint::encode($Body);
 854     }
 855
 856
 857     return ($ContentEncoding, $Body, $MIMEType, $Filename, $note_args );
 858 }
 859
 860 =head2 _DecodeLOB C<ContentType>, C<ContentEncoding>, C<Content>
 861
 862 Unpacks data stored in the database, which may be base64 or QP encoded
 863 because of our need to store binary and badly encoded data in columns
 864 marked as UTF-8.  Databases such as PostgreSQL and Oracle care that you
 865 are feeding them invalid UTF-8 and will refuse the content.  This
 866 function handles unpacking the encoded data.
 867
 868 It returns textual data as a UTF-8 string which has been processed by Encode's
 869 PERLQQ filter which will replace the invalid bytes with \x{HH} so you can see
 870 the invalid byte but won't run into problems treating the data as UTF-8 later.
 871
 872 This is similar to how we filter all data coming in via the web UI in
 873 RT::Interface::Web::DecodeARGS. This filter should only end up being
 874 applied to old data from less UTF-8-safe versions of RT.
 875
 876 If the passed C<ContentType> includes a character set, that will be used
 877 to decode textual data; the default character set is UTF-8.  This is
 878 necessary because while we attempt to store textual data as UTF-8, the
 879 definition of "textual" has migrated over time, and thus we may now need
 880 to attempt to decode data that was previously not trancoded on insertion.
 881
 882 Important Note - This function expects an octet string and returns a
 883 character string for non-binary data.
 884
 885 =cut
 886
 887 sub _DecodeLOB {
 888     my $self            = shift;
 889     my $ContentType     = shift || '';
 890     my $ContentEncoding = shift || 'none';
 891     my $Content         = shift;
 892
 893     RT::Util::assert_bytes( $Content );
 894
 895     if ( $ContentEncoding eq 'base64' ) {
 896         $Content = MIME::Base64::decode_base64($Content);
 897     }
 898     elsif ( $ContentEncoding eq 'quoted-printable' ) {
 899         $Content = MIME::QuotedPrint::decode($Content);
 900     }
 901     elsif ( $ContentEncoding && $ContentEncoding ne 'none' ) {
 902         return ( $self->loc( "Unknown ContentEncoding [_1]", $ContentEncoding ) );
 903     }
 904     if ( RT::I18N::IsTextualContentType($ContentType) ) {
 905         my $entity = MIME::Entity->new();
 906         $entity->head->add("Content-Type", $ContentType);
 907         $entity->bodyhandle( MIME::Body::Scalar->new( $Content ) );
 908         my $charset = RT::I18N::_FindOrGuessCharset($entity);
 909         $charset = 'utf-8' if not $charset or not Encode::find_encoding($charset);
 910
 911         $Content = Encode::decode($charset,$Content,Encode::FB_PERLQQ);
 912     }
 913     return ($Content);
 914 }
 915
 916 =head2 Update  ARGSHASH
 917
 918 Updates fields on an object for you using the proper Set methods,
 919 skipping unchanged values.
 920
 921  ARGSRef => a hashref of attributes => value for the update
 922  AttributesRef => an arrayref of keys in ARGSRef that should be updated
 923  AttributePrefix => a prefix that should be added to the attributes in AttributesRef
 924                     when looking up values in ARGSRef
 925                     Bare attributes are tried before prefixed attributes
 926
 927 Returns a list of localized results of the update
 928
 929 =cut
 930
 931 sub Update {
 932     my $self = shift;
 933
 934     my %args = (
 935         ARGSRef         => undef,
 936         AttributesRef   => undef,
 937         AttributePrefix => undef,
 938         @_
 939     );
 940
 941     my $attributes = $args{'AttributesRef'};
 942     my $ARGSRef    = $args{'ARGSRef'};
 943     my %new_values;
 944
 945     # gather all new values
 946     foreach my $attribute (@$attributes) {
 947         my $value;
 948         if ( defined $ARGSRef->{$attribute} ) {
 949             $value = $ARGSRef->{$attribute};
 950         }
 951         elsif (
 952             defined( $args{'AttributePrefix'} )
 953             && defined(
 954                 $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute }
 955             )
 956           ) {
 957             $value = $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute };
 958
 959         }
 960         else {
 961             next;
 962         }
 963
 964         $value =~ s/\r\n/\n/gs;
 965
 966         my $truncated_value = $self->TruncateValue($attribute, $value);
 967
 968         # If Queue is 'General', we want to resolve the queue name for
 969         # the object.
 970
 971         # This is in an eval block because $object might not exist.
 972         # and might not have a Name method. But "can" won't find autoloaded
 973         # items. If it fails, we don't care
 974         do {
 975             no warnings "uninitialized";
 976             local $@;
 977             my $name = eval {
 978                 my $object = $attribute . "Obj";
 979                 $self->$object->Name;
 980             };
 981             unless ($@) {
 982                 next if $name eq $value || $name eq ($value || 0);
 983             }
 984
 985             next if $truncated_value eq $self->$attribute();
 986             next if ( $truncated_value || 0 ) eq $self->$attribute();
 987         };
 988
 989         $new_values{$attribute} = $value;
 990     }
 991
 992     return $self->_UpdateAttributes(
 993         Attributes => $attributes,
 994         NewValues  => \%new_values,
 995     );
 996 }
 997
 998 sub _UpdateAttributes {
 999     my $self = shift;
1000     my %args = (
1001         Attributes => [],
1002         NewValues  => {},
1003         @_,
1004     );
1005
1006     my @results;
1007
1008     foreach my $attribute (@{ $args{Attributes} }) {
1009         next if !exists($args{NewValues}{$attribute});
1010
1011         my $value = $args{NewValues}{$attribute};
1012         my $method = "Set$attribute";
1013         my ( $code, $msg ) = $self->$method($value);
1014         my ($prefix) = ref($self) =~ /RT(?:.*)::(\w+)/;
1015
1016         # Default to $id, but use name if we can get it.
1017         my $label = $self->id;
1018         $label = $self->Name if (UNIVERSAL::can($self,'Name'));
1019         # this requires model names to be loc'ed.
1020
1021 =for loc
1022
1023     "Ticket" # loc
1024     "User" # loc
1025     "Group" # loc
1026     "Queue" # loc
1027
1028 =cut
1029
1030         push @results, $self->loc( $prefix ) . " $label: ". $msg;
1031
1032 =for loc
1033
1034                                    "[_1] could not be set to [_2].",       # loc
1035                                    "That is already the current value",    # loc
1036                                    "No value sent to _Set!",               # loc
1037                                    "Illegal value for [_1]",               # loc
1038                                    "The new value has been set.",          # loc
1039                                    "No column specified",                  # loc
1040                                    "Immutable field",                      # loc
1041                                    "Nonexistant field?",                   # loc
1042                                    "Invalid data",                         # loc
1043                                    "Couldn't find row",                    # loc
1044                                    "Missing a primary key?: [_1]",         # loc
1045                                    "Found Object",                         # loc
1046
1047 =cut
1048
1049     }
1050
1051     return @results;
1052 }
1053
1054
1055
1056
1057 =head2 Members
1058
1059   This returns an RT::Links object which references all the tickets
1060 which are 'MembersOf' this ticket
1061
1062 =cut
1063
1064 sub Members {
1065     my $self = shift;
1066     return ( $self->_Links( 'Target', 'MemberOf' ) );
1067 }
1068
1069
1070
1071 =head2 MemberOf
1072
1073   This returns an RT::Links object which references all the tickets that this
1074 ticket is a 'MemberOf'
1075
1076 =cut
1077
1078 sub MemberOf {
1079     my $self = shift;
1080     return ( $self->_Links( 'Base', 'MemberOf' ) );
1081 }
1082
1083
1084
1085 =head2 RefersTo
1086
1087   This returns an RT::Links object which shows all references for which this ticket is a base
1088
1089 =cut
1090
1091 sub RefersTo {
1092     my $self = shift;
1093     return ( $self->_Links( 'Base', 'RefersTo' ) );
1094 }
1095
1096
1097
1098 =head2 ReferredToBy
1099
1100 This returns an L<RT::Links> object which shows all references for which this ticket is a target
1101
1102 =cut
1103
1104 sub ReferredToBy {
1105     my $self = shift;
1106     return ( $self->_Links( 'Target', 'RefersTo' ) );
1107 }
1108
1109
1110
1111 =head2 DependedOnBy
1112
1113   This returns an RT::Links object which references all the tickets that depend on this one
1114
1115 =cut
1116
1117 sub DependedOnBy {
1118     my $self = shift;
1119     return ( $self->_Links( 'Target', 'DependsOn' ) );
1120 }
1121
1122
1123
1124
1125 =head2 HasUnresolvedDependencies
1126
1127 Takes a paramhash of Type (default to '__any').  Returns the number of
1128 unresolved dependencies, if $self->UnresolvedDependencies returns an
1129 object with one or more members of that type.  Returns false
1130 otherwise.
1131
1132 =cut
1133
1134 sub HasUnresolvedDependencies {
1135     my $self = shift;
1136     my %args = (
1137         Type   => undef,
1138         @_
1139     );
1140
1141     my $deps = $self->UnresolvedDependencies;
1142
1143     if ($args{Type}) {
1144         $deps->LimitType( VALUE => $args{Type} );
1145     } else {
1146         $deps->IgnoreType;
1147     }
1148
1149     if ($deps->Count > 0) {
1150         return $deps->Count;
1151     }
1152     else {
1153         return (undef);
1154     }
1155 }
1156
1157
1158
1159 =head2 UnresolvedDependencies
1160
1161 Returns an RT::Tickets object of tickets which this ticket depends on
1162 and which have a status of new, open or stalled. (That list comes from
1163 RT::Queue->ActiveStatusArray
1164
1165 =cut
1166
1167
1168 sub UnresolvedDependencies {
1169     my $self = shift;
1170     my $deps = RT::Tickets->new($self->CurrentUser);
1171
1172     $deps->LimitToActiveStatus;
1173     $deps->LimitDependedOnBy($self->Id);
1174
1175     return($deps);
1176
1177 }
1178
1179
1180
1181 =head2 AllDependedOnBy
1182
1183 Returns an array of RT::Ticket objects which (directly or indirectly)
1184 depends on this ticket; takes an optional 'Type' argument in the param
1185 hash, which will limit returned tickets to that type, as well as cause
1186 tickets with that type to serve as 'leaf' nodes that stops the recursive
1187 dependency search.
1188
1189 =cut
1190
1191 sub AllDependedOnBy {
1192     my $self = shift;
1193     return $self->_AllLinkedTickets( LinkType => 'DependsOn',
1194                                      Direction => 'Target', @_ );
1195 }
1196
1197 =head2 AllDependsOn
1198
1199 Returns an array of RT::Ticket objects which this ticket (directly or
1200 indirectly) depends on; takes an optional 'Type' argument in the param
1201 hash, which will limit returned tickets to that type, as well as cause
1202 tickets with that type to serve as 'leaf' nodes that stops the
1203 recursive dependency search.
1204
1205 =cut
1206
1207 sub AllDependsOn {
1208     my $self = shift;
1209     return $self->_AllLinkedTickets( LinkType => 'DependsOn',
1210                                      Direction => 'Base', @_ );
1211 }
1212
1213 sub _AllLinkedTickets {
1214     my $self = shift;
1215
1216     my %args = (
1217         LinkType  => undef,
1218         Direction => undef,
1219         Type   => undef,
1220         _found => {},
1221         _top   => 1,
1222         @_
1223     );
1224
1225     my $dep = $self->_Links( $args{Direction}, $args{LinkType});
1226     while (my $link = $dep->Next()) {
1227         my $uri = $args{Direction} eq 'Target' ? $link->BaseURI : $link->TargetURI;
1228         next unless ($uri->IsLocal());
1229         my $obj = $args{Direction} eq 'Target' ? $link->BaseObj : $link->TargetObj;
1230         next if $args{_found}{$obj->Id};
1231
1232         if (!$args{Type}) {
1233             $args{_found}{$obj->Id} = $obj;
1234             $obj->_AllLinkedTickets( %args, _top => 0 );
1235         }
1236         elsif ($obj->Type and $obj->Type eq $args{Type}) {
1237             $args{_found}{$obj->Id} = $obj;
1238         }
1239         else {
1240             $obj->_AllLinkedTickets( %args, _top => 0 );
1241         }
1242     }
1243
1244     if ($args{_top}) {
1245         return map { $args{_found}{$_} } sort keys %{$args{_found}};
1246     }
1247     else {
1248         return 1;
1249     }
1250 }
1251
1252
1253
1254 =head2 DependsOn
1255
1256   This returns an RT::Links object which references all the tickets that this ticket depends on
1257
1258 =cut
1259
1260 sub DependsOn {
1261     my $self = shift;
1262     return ( $self->_Links( 'Base', 'DependsOn' ) );
1263 }
1264
1265 # }}}
1266
1267 # {{{ Customers
1268
1269 =head2 Customers
1270
1271   This returns an RT::Links object which references all the customers that
1272   this object is a member of.  This includes both explicitly linked customers
1273   and links implied by services.
1274
1275 =cut
1276
1277 sub Customers {
1278     my( $self, %opt ) = @_;
1279     my $Debug = $opt{'Debug'};
1280
1281     unless ( $self->{'Customers'} ) {
1282
1283       $self->{'Customers'} = $self->MemberOf->Clone;
1284
1285       my $RecordType = $self->RecordType;
1286       my $uri_type = $RecordType eq 'Ticket' ? 'ticket' : "RT::$RecordType";
1287
1288       $self->{'Customers'}->Limit( FIELD    => 'Base',
1289                                    OPERATOR => 'STARTSWITH',
1290                                    VALUE    => 'fsck.com-rt://%/'.$uri_type.'/',
1291                                  );
1292
1293       for my $fstable (qw(cust_main cust_svc)) {
1294
1295         $self->{'Customers'}->Limit(
1296                                      FIELD    => 'Target',
1297                                      OPERATOR => 'STARTSWITH',
1298                                      VALUE    => "freeside://freeside/$fstable",
1299                                      ENTRYAGGREGATOR => 'OR',
1300                                      SUBCLAUSE => 'customers',
1301                                    );
1302       }
1303     }
1304
1305     warn "->Customers method called on $self; returning ".
1306          ref($self->{'Customers'}). ' object'
1307       if $Debug;
1308
1309     return $self->{'Customers'};
1310 }
1311
1312 # }}}
1313
1314 # {{{ Services
1315
1316 =head2 Services
1317
1318   This returns an RT::Links object which references all the services this
1319   object is a member of.
1320
1321 =cut
1322
1323 sub Services {
1324     my( $self, %opt ) = @_;
1325
1326     unless ( $self->{'Services'} ) {
1327
1328       $self->{'Services'} = $self->MemberOf->Clone;
1329
1330       $self->{'Services'}->Limit(
1331                                    FIELD    => 'Target',
1332                                    OPERATOR => 'STARTSWITH',
1333                                    VALUE    => "freeside://freeside/cust_svc",
1334                                  );
1335     }
1336
1337     return $self->{'Services'};
1338 }
1339
1340
1341
1342
1343
1344
1345 =head2 Links DIRECTION [TYPE]
1346
1347 Return links (L<RT::Links>) to/from this object.
1348
1349 DIRECTION is either 'Base' or 'Target'.
1350
1351 TYPE is a type of links to return, it can be omitted to get
1352 links of any type.
1353
1354 =cut
1355
1356 sub Links { shift->_Links(@_) }
1357
1358 sub _Links {
1359     my $self = shift;
1360
1361     #TODO: Field isn't the right thing here. but I ahave no idea what mnemonic ---
1362     #tobias meant by $f
1363     my $field = shift;
1364     my $type  = shift || "";
1365
1366     unless ( $self->{"$field$type"} ) {
1367         $self->{"$field$type"} = RT::Links->new( $self->CurrentUser );
1368             # at least to myself
1369             $self->{"$field$type"}->Limit( FIELD => $field,
1370                                            VALUE => $self->URI,
1371                                            ENTRYAGGREGATOR => 'OR' );
1372             $self->{"$field$type"}->Limit( FIELD => 'Type',
1373                                            VALUE => $type )
1374               if ($type);
1375     }
1376     return ( $self->{"$field$type"} );
1377 }
1378
1379
1380
1381
1382 =head2 FormatType
1383
1384 Takes a Type and returns a string that is more human readable.
1385
1386 =cut
1387
1388 sub FormatType{
1389     my $self = shift;
1390     my %args = ( Type => '',
1391                  @_
1392                );
1393     $args{Type} =~ s/([A-Z])/" " . lc $1/ge;
1394     $args{Type} =~ s/^\s+//;
1395     return $args{Type};
1396 }
1397
1398
1399
1400
1401 =head2 FormatLink
1402
1403 Takes either a Target or a Base and returns a string of human friendly text.
1404
1405 =cut
1406
1407 sub FormatLink {
1408     my $self = shift;
1409     my %args = ( Object => undef,
1410                  FallBack => '',
1411                  @_
1412                );
1413     my $text = "URI " . $args{FallBack};
1414     if ($args{Object} && $args{Object}->isa("RT::Ticket")) {
1415         $text = "Ticket " . $args{Object}->id;
1416     }
1417     return $text;
1418 }
1419
1420 =head2 _AddLink
1421
1422 Takes a paramhash of Type and one of Base or Target. Adds that link to this object.
1423
1424 If Silent is true then no transactions will be recorded.  You can individually
1425 control transactions on both base and target and with SilentBase and
1426 SilentTarget respectively. By default both transactions are created.
1427
1428 If the link destination is a local object and does the
1429 L<RT::Record::Role::Status> role, this method ensures object Status is not
1430 "deleted".  Linking to deleted objects is forbidden.
1431
1432 If the link destination (i.e. not C<$self>) is a local object and the
1433 C<$StrictLinkACL> option is enabled, this method checks the appropriate right
1434 on the destination object (if any, as returned by the L</ModifyLinkRight>
1435 method).  B<< The subclass is expected to check the appropriate right on the
1436 source object (i.e.  C<$self>) before calling this method. >>  This allows a
1437 different right to be used on the source object during creation, for example.
1438
1439 Returns a tuple of (link ID, message, flag if link already existed).
1440
1441 =cut
1442
1443 sub _AddLink {
1444     my $self = shift;
1445     my %args = (
1446         Target       => '',
1447         Base         => '',
1448         Type         => '',
1449         Silent       => undef,
1450         Silent       => undef,
1451         SilentBase   => undef,
1452         SilentTarget => undef,
1453         @_
1454     );
1455
1456     # Remote_link is the URI of the object that is not this ticket
1457     my $remote_link;
1458     my $direction;
1459
1460     if ( $args{'Base'} and $args{'Target'} ) {
1461         $RT::Logger->debug( "$self tried to create a link. both base and target were specified" );
1462         return ( 0, $self->loc("Can't specify both base and target") );
1463     }
1464     elsif ( $args{'Base'} ) {
1465         $args{'Target'} = $self->URI();
1466         $remote_link    = $args{'Base'};
1467         $direction      = 'Target';
1468     }
1469     elsif ( $args{'Target'} ) {
1470         $args{'Base'} = $self->URI();
1471         $remote_link  = $args{'Target'};
1472         $direction    = 'Base';
1473     }
1474     else {
1475         return ( 0, $self->loc('Either base or target must be specified') );
1476     }
1477
1478     my $remote_uri = RT::URI->new( $self->CurrentUser );
1479     if ($remote_uri->FromURI( $remote_link )) {
1480         my $remote_obj = $remote_uri->IsLocal ? $remote_uri->Object : undef;
1481         if ($remote_obj and $remote_obj->id) {
1482             # Enforce the remote end of StrictLinkACL
1483             if (RT->Config->Get("StrictLinkACL")) {
1484                 my $right = $remote_obj->ModifyLinkRight;
1485
1486                 return (0, $self->loc("Permission denied"))
1487                     if $right and
1488                    not $self->CurrentUser->HasRight( Right => $right, Object => $remote_obj );
1489             }
1490
1491             # Prevent linking to deleted objects
1492             if ($remote_obj->DOES("RT::Record::Role::Status")
1493                 and $remote_obj->Status eq "deleted") {
1494                 return (0, $self->loc("Linking to a deleted [_1] is not allowed", $self->loc(lc($remote_obj->RecordType))));
1495             }
1496         }
1497     } else {
1498         return (0, $self->loc("Couldn't resolve '[_1]' into a link.", $remote_link));
1499     }
1500
1501     # Check if the link already exists - we don't want duplicates
1502     my $old_link = RT::Link->new( $self->CurrentUser );
1503     $old_link->LoadByParams( Base   => $args{'Base'},
1504                              Type   => $args{'Type'},
1505                              Target => $args{'Target'} );
1506     if ( $old_link->Id ) {
1507         $RT::Logger->debug("$self Somebody tried to duplicate a link");
1508         return ( $old_link->id, $self->loc("Link already exists"), 1 );
1509     }
1510
1511     if ( $args{'Type'} =~ /^(?:DependsOn|MemberOf)$/ ) {
1512
1513         my @tickets = $self->_AllLinkedTickets(
1514             LinkType  => $args{'Type'},
1515             Direction => $direction eq 'Target' ? 'Base' : 'Target',
1516         );
1517         if ( grep { $_->id == ( $direction eq 'Target' ? $args{'Base'} : $args{'Target'} ) } @tickets ) {
1518             return ( 0, $self->loc("Refused to add link which would create a circular relationship") );
1519         }
1520     }
1521
1522     # Storing the link in the DB.
1523     my $link = RT::Link->new( $self->CurrentUser );
1524     my ($linkid, $linkmsg) = $link->Create( Target => $args{Target},
1525                                             Base   => $args{Base},
1526                                             Type   => $args{Type} );
1527
1528     unless ($linkid) {
1529         $RT::Logger->error("Link could not be created: ".$linkmsg);
1530         return ( 0, $self->loc("Link could not be created: [_1]", $linkmsg) );
1531     }
1532
1533     my $basetext = $self->FormatLink(Object   => $link->BaseObj,
1534                                      FallBack => $args{Base});
1535     my $targettext = $self->FormatLink(Object   => $link->TargetObj,
1536                                        FallBack => $args{Target});
1537     my $typetext = $self->FormatType(Type => $args{Type});
1538     my $TransString = "$basetext $typetext $targettext.";
1539
1540     # No transactions for you!
1541     return ($linkid, $TransString) if $args{'Silent'};
1542
1543     my $opposite_direction = $direction eq 'Target' ? 'Base': 'Target';
1544
1545     # Some transactions?
1546     unless ( $args{ 'Silent'. $direction } ) {
1547         my ( $Trans, $Msg, $TransObj ) = $self->_NewTransaction(
1548             Type      => 'AddLink',
1549             Field     => $RT::Link::DIRMAP{$args{'Type'}}->{$direction},
1550             NewValue  => $remote_uri->URI || $remote_link,
1551             TimeTaken => 0
1552         );
1553         $RT::Logger->error("Couldn't create transaction: $Msg") unless $Trans;
1554     }
1555
1556     if ( !$args{"Silent$opposite_direction"} && $remote_uri->IsLocal ) {
1557         my $OtherObj = $remote_uri->Object;
1558         my ( $val, $msg ) = $OtherObj->_NewTransaction(
1559             Type           => 'AddLink',
1560             Field          => $RT::Link::DIRMAP{$args{'Type'}}->{$opposite_direction},
1561             NewValue       => $self->URI,
1562             TimeTaken      => 0,
1563         );
1564         $RT::Logger->error("Couldn't create transaction: $msg") unless $val;
1565     }
1566
1567     return ($linkid, $TransString);
1568 }
1569
1570 =head2 _DeleteLink
1571
1572 Takes a paramhash of Type and one of Base or Target. Removes that link from this object.
1573
1574 If Silent is true then no transactions will be recorded.  You can individually
1575 control transactions on both base and target and with SilentBase and
1576 SilentTarget respectively. By default both transactions are created.
1577
1578 If the link destination (i.e. not C<$self>) is a local object and the
1579 C<$StrictLinkACL> option is enabled, this method checks the appropriate right
1580 on the destination object (if any, as returned by the L</ModifyLinkRight>
1581 method).  B<< The subclass is expected to check the appropriate right on the
1582 source object (i.e.  C<$self>) before calling this method. >>
1583
1584 Returns a tuple of (status flag, message).
1585
1586 =cut
1587
1588 sub _DeleteLink {
1589     my $self = shift;
1590     my %args = (
1591         Base         => undef,
1592         Target       => undef,
1593         Type         => undef,
1594         Silent       => undef,
1595         SilentBase   => undef,
1596         SilentTarget => undef,
1597         @_
1598     );
1599
1600     # We want one of base and target. We don't care which but we only want _one_.
1601     my $direction;
1602     my $remote_link;
1603
1604     if ( $args{'Base'} and $args{'Target'} ) {
1605         $RT::Logger->debug("$self ->_DeleteLink. got both Base and Target");
1606         return ( 0, $self->loc("Can't specify both base and target") );
1607     }
1608     elsif ( $args{'Base'} ) {
1609         $args{'Target'} = $self->URI();
1610         $remote_link    = $args{'Base'};
1611         $direction      = 'Target';
1612     }
1613     elsif ( $args{'Target'} ) {
1614         $args{'Base'} = $self->URI();
1615         $remote_link  = $args{'Target'};
1616         $direction    = 'Base';
1617     }
1618     else {
1619         $RT::Logger->error("Base or Target must be specified");
1620         return ( 0, $self->loc('Either base or target must be specified') );
1621     }
1622
1623     my $remote_uri = RT::URI->new( $self->CurrentUser );
1624     if ($remote_uri->FromURI( $remote_link )) {
1625         # Enforce the remote end of StrictLinkACL
1626         my $remote_obj = $remote_uri->IsLocal ? $remote_uri->Object : undef;
1627         if ($remote_obj and $remote_obj->id and RT->Config->Get("StrictLinkACL")) {
1628             my $right = $remote_obj->ModifyLinkRight;
1629
1630             return (0, $self->loc("Permission denied"))
1631                 if $right and
1632                not $self->CurrentUser->HasRight( Right => $right, Object => $remote_obj );
1633         }
1634     } else {
1635         return (0, $self->loc("Couldn't resolve '[_1]' into a link.", $remote_link));
1636     }
1637
1638     my $link = RT::Link->new( $self->CurrentUser );
1639     $RT::Logger->debug( "Trying to load link: "
1640             . $args{'Base'} . " "
1641             . $args{'Type'} . " "
1642             . $args{'Target'} );
1643
1644     $link->LoadByParams(
1645         Base   => $args{'Base'},
1646         Type   => $args{'Type'},
1647         Target => $args{'Target'}
1648     );
1649
1650     unless ($link->id) {
1651         $RT::Logger->debug("Couldn't find that link");
1652         return ( 0, $self->loc("Link not found") );
1653     }
1654
1655     my $basetext = $self->FormatLink(Object   => $link->BaseObj,
1656                                      FallBack => $args{Base});
1657     my $targettext = $self->FormatLink(Object   => $link->TargetObj,
1658                                        FallBack => $args{Target});
1659     my $typetext = $self->FormatType(Type => $args{Type});
1660     my $TransString = "$basetext no longer $typetext $targettext.";
1661
1662     my ($ok, $msg) = $link->Delete();
1663     unless ($ok) {
1664         RT->Logger->error("Link could not be deleted: $msg");
1665         return ( 0, $self->loc("Link could not be deleted: [_1]", $msg) );
1666     }
1667
1668     # No transactions for you!
1669     return (1, $TransString) if $args{'Silent'};
1670
1671     my $opposite_direction = $direction eq 'Target' ? 'Base': 'Target';
1672
1673     # Some transactions?
1674     unless ( $args{ 'Silent'. $direction } ) {
1675         my ( $Trans, $Msg, $TransObj ) = $self->_NewTransaction(
1676             Type      => 'DeleteLink',
1677             Field     => $RT::Link::DIRMAP{$args{'Type'}}->{$direction},
1678             OldValue  => $remote_uri->URI || $remote_link,
1679             TimeTaken => 0
1680         );
1681         $RT::Logger->error("Couldn't create transaction: $Msg") unless $Trans;
1682     }
1683
1684     if ( !$args{"Silent$opposite_direction"} && $remote_uri->IsLocal ) {
1685         my $OtherObj = $remote_uri->Object;
1686         my ( $val, $msg ) = $OtherObj->_NewTransaction(
1687             Type           => 'DeleteLink',
1688             Field          => $RT::Link::DIRMAP{$args{'Type'}}->{$opposite_direction},
1689             OldValue       => $self->URI,
1690             TimeTaken      => 0,
1691         );
1692         $RT::Logger->error("Couldn't create transaction: $msg") unless $val;
1693     }
1694
1695     return (1, $TransString);
1696 }
1697
1698 =head1 LockForUpdate
1699
1700 In a database transaction, gains an exclusive lock on the row, to
1701 prevent race conditions.  On SQLite, this is a "RESERVED" lock on the
1702 entire database.
1703
1704 =cut
1705
1706 sub LockForUpdate {
1707     my $self = shift;
1708
1709     my $pk = $self->_PrimaryKey;
1710     my $id = @_ ? $_[0] : $self->$pk;
1711     $self->_expire if $self->isa("DBIx::SearchBuilder::Record::Cachable");
1712     if (RT->Config->Get('DatabaseType') eq "SQLite") {
1713         # SQLite does DB-level locking, upgrading the transaction to
1714         # "RESERVED" on the first UPDATE/INSERT/DELETE.  Do a no-op
1715         # UPDATE to force the upgade.
1716         return RT->DatabaseHandle->dbh->do(
1717             "UPDATE " .$self->Table.
1718                 " SET $pk = $pk WHERE 1 = 0");
1719     } else {
1720         return $self->_LoadFromSQL(
1721             "SELECT * FROM ".$self->Table
1722                 ." WHERE $pk = ? FOR UPDATE",
1723             $id,
1724         );
1725     }
1726 }
1727
1728 =head2 _NewTransaction  PARAMHASH
1729
1730 Private function to create a new RT::Transaction object for this ticket update
1731
1732 =cut
1733
1734 sub _NewTransaction {
1735     my $self = shift;
1736     my %args = (
1737         TimeTaken => undef,
1738         Type      => undef,
1739         OldValue  => undef,
1740         NewValue  => undef,
1741         OldReference  => undef,
1742         NewReference  => undef,
1743         ReferenceType => undef,
1744         Data      => undef,
1745         Field     => undef,
1746         MIMEObj   => undef,
1747         ActivateScrips => 1,
1748         CommitScrips => 1,
1749         SquelchMailTo => undef,
1750         CustomFields => {},
1751         @_
1752     );
1753
1754     my $in_txn = RT->DatabaseHandle->TransactionDepth;
1755     RT->DatabaseHandle->BeginTransaction unless $in_txn;
1756
1757     $self->LockForUpdate;
1758
1759     my $old_ref = $args{'OldReference'};
1760     my $new_ref = $args{'NewReference'};
1761     my $ref_type = $args{'ReferenceType'};
1762     if ($old_ref or $new_ref) {
1763         $ref_type ||= ref($old_ref) || ref($new_ref);
1764         if (!$ref_type) {
1765             $RT::Logger->error("Reference type not specified for transaction");
1766             return;
1767         }
1768         $old_ref = $old_ref->Id if ref($old_ref);
1769         $new_ref = $new_ref->Id if ref($new_ref);
1770     }
1771
1772     require RT::Transaction;
1773     my $trans = RT::Transaction->new( $self->CurrentUser );
1774     my ( $transaction, $msg ) = $trans->Create(
1775         ObjectId  => $self->Id,
1776         ObjectType => ref($self),
1777         TimeTaken => $args{'TimeTaken'},
1778         Type      => $args{'Type'},
1779         Data      => $args{'Data'},
1780         Field     => $args{'Field'},
1781         NewValue  => $args{'NewValue'},
1782         OldValue  => $args{'OldValue'},
1783         NewReference  => $new_ref,
1784         OldReference  => $old_ref,
1785         ReferenceType => $ref_type,
1786         MIMEObj   => $args{'MIMEObj'},
1787         ActivateScrips => $args{'ActivateScrips'},
1788         CommitScrips => $args{'CommitScrips'},
1789         SquelchMailTo => $args{'SquelchMailTo'},
1790         CustomFields => $args{'CustomFields'},
1791     );
1792
1793     # Rationalize the object since we may have done things to it during the caching.
1794     $self->Load($self->Id);
1795
1796     $RT::Logger->warning($msg) unless $transaction;
1797
1798     $self->_SetLastUpdated;
1799
1800     if ( defined $args{'TimeTaken'} and $self->can('_UpdateTimeTaken')) {
1801         $self->_UpdateTimeTaken( $args{'TimeTaken'}, Transaction => $trans );
1802     }
1803     if ( RT->Config->Get('UseTransactionBatch') and $transaction ) {
1804             push @{$self->{_TransactionBatch}}, $trans if $args{'CommitScrips'};
1805     }
1806
1807     RT->DatabaseHandle->Commit unless $in_txn;
1808
1809     return ( $transaction, $msg, $trans );
1810 }
1811
1812
1813
1814 =head2 Transactions
1815
1816 Returns an L<RT::Transactions> object of all transactions on this record object
1817
1818 =cut
1819
1820 sub Transactions {
1821     my $self = shift;
1822
1823     my $transactions = RT::Transactions->new( $self->CurrentUser );
1824     $transactions->Limit(
1825         FIELD => 'ObjectId',
1826         VALUE => $self->id,
1827     );
1828     $transactions->Limit(
1829         FIELD => 'ObjectType',
1830         VALUE => ref($self),
1831     );
1832
1833     return $transactions;
1834 }
1835
1836 =head2 SortedTransactions
1837
1838 Returns the result of L</Transactions> ordered per the
1839 I<OldestTransactionsFirst> preference/option.
1840
1841 =cut
1842
1843 sub SortedTransactions {
1844     my $self  = shift;
1845     my $txns  = $self->Transactions;
1846     my $order = RT->Config->Get("OldestTransactionsFirst", $self->CurrentUser)
1847         ? 'ASC' : 'DESC';
1848     $txns->OrderByCols(
1849         { FIELD => 'Created',   ORDER => $order },
1850         { FIELD => 'id',        ORDER => $order },
1851     );
1852     return $txns;
1853 }
1854
1855 our %TRANSACTION_CLASSIFICATION = (
1856     Create     => 'message',
1857     Correspond => 'message',
1858     Comment    => 'message',
1859
1860     AddWatcher => 'people',
1861     DelWatcher => 'people',
1862
1863     Take       => 'people',
1864     Untake     => 'people',
1865     Force      => 'people',
1866     Steal      => 'people',
1867     Give       => 'people',
1868
1869     AddLink    => 'links',
1870     DeleteLink => 'links',
1871
1872     Status     => 'basics',
1873     Set        => {
1874         __default => 'basics',
1875         map( { $_ => 'dates' } qw(
1876             Told Starts Started Due LastUpdated Created LastUpdated
1877         ) ),
1878         map( { $_ => 'people' } qw(
1879             Owner Creator LastUpdatedBy
1880         ) ),
1881     },
1882     SystemError => 'error',
1883     AttachmentTruncate => 'attachment-truncate',
1884     AttachmentDrop => 'attachment-drop',
1885     AttachmentError => 'error',
1886     __default => 'other',
1887 );
1888
1889 sub ClassifyTransaction {
1890     my $self = shift;
1891     my $txn = shift;
1892
1893     my $type = $txn->Type;
1894
1895     my $res = $TRANSACTION_CLASSIFICATION{ $type };
1896     return $res || $TRANSACTION_CLASSIFICATION{ '__default' }
1897         unless ref $res;
1898
1899     return $res->{ $txn->Field } || $res->{'__default'}
1900         || $TRANSACTION_CLASSIFICATION{ '__default' };
1901 }
1902
1903 =head2 Attachments
1904
1905 Returns an L<RT::Attachments> object of all attachments on this record object
1906 (for all its L</Transactions>).
1907
1908 By default Content and Headers of attachments are not fetched right away from
1909 database. Use C<WithContent> and C<WithHeaders> options to override this.
1910
1911 =cut
1912
1913 sub Attachments {
1914     my $self = shift;
1915     my %args = (
1916         WithHeaders => 0,
1917         WithContent => 0,
1918         @_
1919     );
1920     my @columns = grep { not /^(Headers|Content)$/ }
1921                        RT::Attachment->ReadableAttributes;
1922     push @columns, 'Headers' if $args{'WithHeaders'};
1923     push @columns, 'Content' if $args{'WithContent'};
1924
1925     my $res = RT::Attachments->new( $self->CurrentUser );
1926     $res->Columns( @columns );
1927     my $txn_alias = $res->TransactionAlias;
1928     $res->Limit(
1929         ALIAS => $txn_alias,
1930         FIELD => 'ObjectType',
1931         VALUE => ref($self),
1932     );
1933     $res->Limit(
1934         ALIAS => $txn_alias,
1935         FIELD => 'ObjectId',
1936         VALUE => $self->id,
1937     );
1938     return $res;
1939 }
1940
1941 =head2 TextAttachments
1942
1943 Returns an L<RT::Attachments> object of all attachments, like L<Attachments>,
1944 but only those that are text.
1945
1946 By default Content and Headers are fetched. Use C<WithContent> and
1947 C<WithHeaders> options to override this.
1948
1949 =cut
1950
1951 sub TextAttachments {
1952     my $self = shift;
1953     my $res = $self->Attachments(
1954         WithHeaders => 1,
1955         WithContent => 1,
1956         @_
1957     );
1958     $res->Limit( FIELD => 'ContentType', OPERATOR => '=', VALUE => 'text/plain');
1959     $res->Limit( FIELD => 'ContentType', OPERATOR => 'STARTSWITH', VALUE => 'message/');
1960     $res->Limit( FIELD => 'ContentType', OPERATOR => '=', VALUE => 'text');
1961     $res->Limit( FIELD => 'Filename', OPERATOR => 'IS', VALUE => 'NULL')
1962         if RT->Config->Get( 'SuppressInlineTextFiles', $self->CurrentUser );
1963     return $res;
1964 }
1965
1966 sub CustomFields {
1967     my $self = shift;
1968     my $cfs  = RT::CustomFields->new( $self->CurrentUser );
1969
1970     $cfs->SetContextObject( $self );
1971     # XXX handle multiple types properly
1972     $cfs->LimitToLookupType( $self->CustomFieldLookupType );
1973     $cfs->LimitToGlobalOrObjectId( $self->CustomFieldLookupId );
1974     $cfs->ApplySortOrder;
1975
1976     return $cfs;
1977 }
1978
1979 # TODO: This _only_ works for RT::Foo classes. it doesn't work, for
1980 # example, for RT::IR::Foo classes.
1981
1982 sub CustomFieldLookupId {
1983     my $self = shift;
1984     my $lookup = shift || $self->CustomFieldLookupType;
1985     my @classes = ($lookup =~ /RT::(\w+)-/g);
1986
1987     # Work on "RT::Queue", for instance
1988     return $self->Id unless @classes;
1989
1990     my $object = $self;
1991     # Save a ->Load call by not calling ->FooObj->Id, just ->Foo
1992     my $final = shift @classes;
1993     foreach my $class (reverse @classes) {
1994         my $method = "${class}Obj";
1995         $object = $object->$method;
1996     }
1997
1998     my $id = $object->$final;
1999     unless (defined $id) {
2000         my $method = "${final}Obj";
2001         $id = $object->$method->Id;
2002     }
2003     return $id;
2004 }
2005
2006
2007 =head2 CustomFieldLookupType
2008
2009 Returns the path RT uses to figure out which custom fields apply to this object.
2010
2011 =cut
2012
2013 sub CustomFieldLookupType {
2014     my $self = shift;
2015     return ref($self) || $self;
2016 }
2017
2018
2019 =head2 AddCustomFieldValue { Field => FIELD, Value => VALUE }
2020
2021 VALUE should be a string. FIELD can be any identifier of a CustomField
2022 supported by L</LoadCustomFieldByIdentifier> method.
2023
2024 Adds VALUE as a value of CustomField FIELD. If this is a single-value custom field,
2025 deletes the old value.
2026 If VALUE is not a valid value for the custom field, returns
2027 (0, 'Error message' ) otherwise, returns ($id, 'Success Message') where
2028 $id is ID of created L<ObjectCustomFieldValue> object.
2029
2030 =cut
2031
2032 sub AddCustomFieldValue {
2033     my $self = shift;
2034     $self->_AddCustomFieldValue(@_);
2035 }
2036
2037 sub _AddCustomFieldValue {
2038     my $self = shift;
2039     my %args = (
2040         Field             => undef,
2041         Value             => undef,
2042         LargeContent      => undef,
2043         ContentType       => undef,
2044         RecordTransaction => 1,
2045         @_
2046     );
2047
2048     my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
2049     unless ( $cf->Id ) {
2050         return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
2051     }
2052
2053     my $OCFs = $self->CustomFields;
2054     $OCFs->Limit( FIELD => 'id', VALUE => $cf->Id );
2055     unless ( $OCFs->Count ) {
2056         return (
2057             0,
2058             $self->loc(
2059                 "Custom field [_1] does not apply to this object",
2060                 ref $args{'Field'} ? $args{'Field'}->id : $args{'Field'}
2061             )
2062         );
2063     }
2064
2065     # empty string is not correct value of any CF, so undef it
2066     foreach ( qw(Value LargeContent) ) {
2067         $args{ $_ } = undef if defined $args{ $_ } && !length $args{ $_ };
2068     }
2069
2070     unless ( $cf->ValidateValue( $args{'Value'} ) ) {
2071         return ( 0, $self->loc("Invalid value for custom field") );
2072     }
2073
2074     # If the custom field only accepts a certain # of values, delete the existing
2075     # value and record a "changed from foo to bar" transaction
2076     unless ( $cf->UnlimitedValues ) {
2077
2078         # Load up a ObjectCustomFieldValues object for this custom field and this ticket
2079         my $values = $cf->ValuesForObject($self);
2080
2081         # We need to whack any old values here.  In most cases, the custom field should
2082         # only have one value to delete.  In the pathalogical case, this custom field
2083         # used to be a multiple and we have many values to whack....
2084         my $cf_values = $values->Count;
2085
2086         if ( $cf_values > $cf->MaxValues ) {
2087             my $i = 0;   #We want to delete all but the max we can currently have , so we can then
2088                  # execute the same code to "change" the value from old to new
2089             while ( my $value = $values->Next ) {
2090                 $i++;
2091                 if ( $i < $cf_values ) {
2092                     my ( $val, $msg ) = $cf->DeleteValueForObject(
2093                         Object => $self,
2094                         Id     => $value->id,
2095                     );
2096                     unless ($val) {
2097                         return ( 0, $msg );
2098                     }
2099                     my ( $TransactionId, $Msg, $TransactionObj ) =
2100                       $self->_NewTransaction(
2101                         Type         => 'CustomField',
2102                         Field        => $cf->Id,
2103                         OldReference => $value,
2104                       );
2105                 }
2106             }
2107             $values->RedoSearch if $i; # redo search if have deleted at least one value
2108         }
2109
2110         if ( my $entry = $values->HasEntry($args{'Value'}, $args{'LargeContent'}) ) {
2111             return $entry->id;
2112         }
2113
2114         my $old_value = $values->First;
2115         my $old_content;
2116         $old_content = $old_value->Content if $old_value;
2117
2118         my ( $new_value_id, $value_msg ) = $cf->AddValueForObject(
2119             Object       => $self,
2120             Content      => $args{'Value'},
2121             LargeContent => $args{'LargeContent'},
2122             ContentType  => $args{'ContentType'},
2123         );
2124
2125         unless ( $new_value_id ) {
2126             return ( 0, $self->loc( "Could not add new custom field value: [_1]", $value_msg ) );
2127         }
2128
2129         my $new_value = RT::ObjectCustomFieldValue->new( $self->CurrentUser );
2130         $new_value->Load( $new_value_id );
2131
2132         # now that adding the new value was successful, delete the old one
2133         if ( $old_value ) {
2134             my ( $val, $msg ) = $old_value->Delete();
2135             return ( 0, $msg ) unless $val;
2136         }
2137
2138         if ( $args{'RecordTransaction'} ) {
2139             my ( $TransactionId, $Msg, $TransactionObj ) =
2140               $self->_NewTransaction(
2141                 Type         => 'CustomField',
2142                 Field        => $cf->Id,
2143                 OldReference => $old_value,
2144                 NewReference => $new_value,
2145               );
2146         }
2147
2148         my $new_content = $new_value->Content;
2149
2150         # For datetime, we need to display them in "human" format in result message
2151         #XXX TODO how about date without time?
2152         if ($cf->Type eq 'DateTime') {
2153             my $DateObj = RT::Date->new( $self->CurrentUser );
2154             $DateObj->Set(
2155                 Format => 'ISO',
2156                 Value  => $new_content,
2157             );
2158             $new_content = $DateObj->AsString;
2159
2160             if ( defined $old_content && length $old_content ) {
2161                 $DateObj->Set(
2162                     Format => 'ISO',
2163                     Value  => $old_content,
2164                 );
2165                 $old_content = $DateObj->AsString;
2166             }
2167         }
2168
2169         unless ( defined $old_content && length $old_content ) {
2170             return ( $new_value_id, $self->loc( "[_1] [_2] added", $cf->Name, $new_content ));
2171         }
2172         elsif ( !defined $new_content || !length $new_content ) {
2173             return ( $new_value_id,
2174                 $self->loc( "[_1] [_2] deleted", $cf->Name, $old_content ) );
2175         }
2176         else {
2177             return ( $new_value_id, $self->loc( "[_1] [_2] changed to [_3]", $cf->Name, $old_content, $new_content));
2178         }
2179
2180     }
2181
2182     # otherwise, just add a new value and record "new value added"
2183     else {
2184         my $values = $cf->ValuesForObject($self);
2185         if ( my $entry = $values->HasEntry($args{'Value'}, $args{'LargeContent'}) ) {
2186             return $entry->id;
2187         }
2188
2189         my ($new_value_id, $msg) = $cf->AddValueForObject(
2190             Object       => $self,
2191             Content      => $args{'Value'},
2192             LargeContent => $args{'LargeContent'},
2193             ContentType  => $args{'ContentType'},
2194         );
2195
2196         unless ( $new_value_id ) {
2197             return ( 0, $self->loc( "Could not add new custom field value: [_1]", $msg ) );
2198         }
2199
2200         if ( $args{'RecordTransaction'} ) {
2201             my ( $tid, $msg ) = $self->_NewTransaction(
2202                 Type          => 'CustomField',
2203                 Field         => $cf->Id,
2204                 NewReference  => $new_value_id,
2205                 ReferenceType => 'RT::ObjectCustomFieldValue',
2206             );
2207             unless ( $tid ) {
2208                 return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $msg ) );
2209             }
2210         }
2211         return ( $new_value_id, $self->loc( "[_1] added as a value for [_2]", $args{'Value'}, $cf->Name ) );
2212     }
2213 }
2214
2215
2216
2217 =head2 DeleteCustomFieldValue { Field => FIELD, Value => VALUE }
2218
2219 Deletes VALUE as a value of CustomField FIELD.
2220
2221 VALUE can be a string, a CustomFieldValue or a ObjectCustomFieldValue.
2222
2223 If VALUE is not a valid value for the custom field, returns
2224 (0, 'Error message' ) otherwise, returns (1, 'Success Message')
2225
2226 =cut
2227
2228 sub DeleteCustomFieldValue {
2229     my $self = shift;
2230     my %args = (
2231         Field   => undef,
2232         Value   => undef,
2233         ValueId => undef,
2234         @_
2235     );
2236
2237     my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
2238     unless ( $cf->Id ) {
2239         return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
2240     }
2241
2242     my ( $val, $msg ) = $cf->DeleteValueForObject(
2243         Object  => $self,
2244         Id      => $args{'ValueId'},
2245         Content => $args{'Value'},
2246     );
2247     unless ($val) {
2248         return ( 0, $msg );
2249     }
2250
2251     my ( $TransactionId, $Msg, $TransactionObj ) = $self->_NewTransaction(
2252         Type          => 'CustomField',
2253         Field         => $cf->Id,
2254         OldReference  => $val,
2255         ReferenceType => 'RT::ObjectCustomFieldValue',
2256     );
2257     unless ($TransactionId) {
2258         return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $Msg ) );
2259     }
2260
2261     my $old_value = $TransactionObj->OldValue;
2262     # For datetime, we need to display them in "human" format in result message
2263     if ( $cf->Type eq 'DateTime' ) {
2264         my $DateObj = RT::Date->new( $self->CurrentUser );
2265         $DateObj->Set(
2266             Format => 'ISO',
2267             Value  => $old_value,
2268         );
2269         $old_value = $DateObj->AsString;
2270     }
2271     return (
2272         $TransactionId,
2273         $self->loc(
2274             "[_1] is no longer a value for custom field [_2]",
2275             $old_value, $cf->Name
2276         )
2277     );
2278 }
2279
2280
2281
2282 =head2 FirstCustomFieldValue FIELD
2283
2284 Return the content of the first value of CustomField FIELD for this ticket
2285 Takes a field id or name
2286
2287 =cut
2288
2289 sub FirstCustomFieldValue {
2290     my $self = shift;
2291     my $field = shift;
2292
2293     my $values = $self->CustomFieldValues( $field );
2294     return undef unless my $first = $values->First;
2295     return $first->Content;
2296 }
2297
2298 =head2 CustomFieldValuesAsString FIELD
2299
2300 Return the content of the CustomField FIELD for this ticket.
2301 If this is a multi-value custom field, values will be joined with newlines.
2302
2303 Takes a field id or name as the first argument
2304
2305 Takes an optional Separator => "," second and third argument
2306 if you want to join the values using something other than a newline
2307
2308 =cut
2309
2310 sub CustomFieldValuesAsString {
2311     my $self  = shift;
2312     my $field = shift;
2313     my %args  = @_;
2314     my $separator = $args{Separator} || "\n";
2315
2316     my $values = $self->CustomFieldValues( $field );
2317     return join ($separator, grep { defined $_ }
2318                  map { $_->Content } @{$values->ItemsArrayRef});
2319 }
2320
2321
2322
2323 =head2 CustomFieldValues FIELD
2324
2325 Return a ObjectCustomFieldValues object of all values of the CustomField whose
2326 id or Name is FIELD for this record.
2327
2328 Returns an RT::ObjectCustomFieldValues object
2329
2330 =cut
2331
2332 sub CustomFieldValues {
2333     my $self  = shift;
2334     my $field = shift;
2335
2336     if ( $field ) {
2337         my $cf = $self->LoadCustomFieldByIdentifier( $field );
2338
2339         # we were asked to search on a custom field we couldn't find
2340         unless ( $cf->id ) {
2341             $RT::Logger->warning("Couldn't load custom field by '$field' identifier");
2342             return RT::ObjectCustomFieldValues->new( $self->CurrentUser );
2343         }
2344         return ( $cf->ValuesForObject($self) );
2345     }
2346
2347     # we're not limiting to a specific custom field;
2348     my $ocfs = RT::ObjectCustomFieldValues->new( $self->CurrentUser );
2349     $ocfs->LimitToObject( $self );
2350     return $ocfs;
2351 }
2352
2353 =head2 LoadCustomFieldByIdentifier IDENTIFER
2354
2355 Find the custom field has id or name IDENTIFIER for this object.
2356
2357 If no valid field is found, returns an empty RT::CustomField object.
2358
2359 =cut
2360
2361 sub LoadCustomFieldByIdentifier {
2362     my $self = shift;
2363     my $field = shift;
2364
2365     my $cf;
2366     if ( UNIVERSAL::isa( $field, "RT::CustomField" ) ) {
2367         $cf = RT::CustomField->new($self->CurrentUser);
2368         $cf->SetContextObject( $self );
2369         $cf->LoadById( $field->id );
2370     }
2371     elsif ($field =~ /^\d+$/) {
2372         $cf = RT::CustomField->new($self->CurrentUser);
2373         $cf->SetContextObject( $self );
2374         $cf->LoadById($field);
2375     } else {
2376
2377         my $cfs = $self->CustomFields($self->CurrentUser);
2378         $cfs->SetContextObject( $self );
2379         $cfs->Limit(FIELD => 'Name', VALUE => $field, CASESENSITIVE => 0);
2380         $cf = $cfs->First || RT::CustomField->new($self->CurrentUser);
2381     }
2382     return $cf;
2383 }
2384
2385 sub ACLEquivalenceObjects { }
2386
2387 =head2 HasRight
2388
2389  Takes a paramhash with the attributes 'Right' and 'Principal'
2390   'Right' is a ticket-scoped textual right from RT::ACE
2391   'Principal' is an RT::User object
2392
2393   Returns 1 if the principal has the right. Returns undef if not.
2394
2395 =cut
2396
2397 sub HasRight {
2398     my $self = shift;
2399     my %args = (
2400         Right     => undef,
2401         Principal => undef,
2402         @_
2403     );
2404
2405     $args{Principal} ||= $self->CurrentUser->PrincipalObj;
2406
2407     return $args{'Principal'}->HasRight(
2408         Object => $self->Id ? $self : $RT::System,
2409         Right  => $args{'Right'}
2410     );
2411 }
2412
2413 sub CurrentUserHasRight {
2414     my $self = shift;
2415     return $self->HasRight( Right => @_ );
2416 }
2417
2418 sub ModifyLinkRight { }
2419
2420 =head2 ColumnMapClassName
2421
2422 ColumnMap needs a massaged collection class name to load the correct list
2423 display.  Equivalent to L<RT::SearchBuilder/ColumnMapClassName>, but provided
2424 for a record instead of a collection.
2425
2426 Returns a string.  May be called as a package method.
2427
2428 =cut
2429
2430 sub ColumnMapClassName {
2431     my $self  = shift;
2432     my $Class = ref($self) || $self;
2433        $Class =~ s/:/_/g;
2434     return $Class;
2435 }
2436
2437 sub BasicColumns { }
2438
2439 sub WikiBase {
2440     return RT->Config->Get('WebPath'). "/index.html?q=";
2441 }
2442
2443 sub UID {
2444     my $self = shift;
2445     return undef unless defined $self->Id;
2446     return "@{[ref $self]}-$RT::Organization-@{[$self->Id]}";
2447 }
2448
2449 sub FindDependencies {
2450     my $self = shift;
2451     my ($walker, $deps) = @_;
2452     for my $col (qw/Creator LastUpdatedBy/) {
2453         if ( $self->_Accessible( $col, 'read' ) ) {
2454             next unless $self->$col;
2455             my $obj = RT::Principal->new( $self->CurrentUser );
2456             $obj->Load( $self->$col );
2457             $deps->Add( out => $obj->Object );
2458         }
2459     }
2460
2461     # Object attributes, we have to check on every object
2462     my $objs = $self->Attributes;
2463     $deps->Add( in => $objs );
2464
2465     # Transactions
2466     if (   $self->isa("RT::Ticket")
2467         or $self->isa("RT::User")
2468         or $self->isa("RT::Group")
2469         or $self->isa("RT::Article")
2470         or $self->isa("RT::Queue") )
2471     {
2472         $objs = RT::Transactions->new( $self->CurrentUser );
2473         $objs->Limit( FIELD => 'ObjectType', VALUE => ref $self );
2474         $objs->Limit( FIELD => 'ObjectId', VALUE => $self->id );
2475         $deps->Add( in => $objs );
2476     }
2477
2478     # Object custom field values
2479     if ((   $self->isa("RT::Transaction")
2480          or $self->isa("RT::Ticket")
2481          or $self->isa("RT::User")
2482          or $self->isa("RT::Group")
2483          or $self->isa("RT::Queue")
2484          or $self->isa("RT::Article") )
2485             and $self->can("CustomFieldValues") )
2486     {
2487         $objs = $self->CustomFieldValues; # Actually OCFVs
2488         $objs->{find_expired_rows} = 1;
2489         $deps->Add( in => $objs );
2490     }
2491
2492     # ACE records
2493     if (   $self->isa("RT::Group")
2494         or $self->isa("RT::Class")
2495         or $self->isa("RT::Queue")
2496         or $self->isa("RT::CustomField") )
2497     {
2498         $objs = RT::ACL->new( $self->CurrentUser );
2499         $objs->LimitToObject( $self );
2500         $deps->Add( in => $objs );
2501     }
2502 }
2503
2504 sub Serialize {
2505     my $self = shift;
2506     my %args = (
2507         Methods => {},
2508         UIDs    => 1,
2509         @_,
2510     );
2511     my %methods = (
2512         Creator       => "CreatorObj",
2513         LastUpdatedBy => "LastUpdatedByObj",
2514         %{ $args{Methods} || {} },
2515     );
2516
2517     my %values = %{$self->{values}};
2518
2519     my %ca = %{ $self->_ClassAccessible };
2520     my @cols = grep {exists $values{lc $_} and defined $values{lc $_}} keys %ca;
2521
2522     my %store;
2523     $store{$_} = $values{lc $_} for @cols;
2524     $store{id} = $values{id}; # Explicitly necessary in some cases
2525
2526     # Un-apply the _transfer_ encoding, but don't mess with the octets
2527     # themselves.  Calling ->Content directly would, in some cases,
2528     # decode from some mostly-unknown character set -- which reversing
2529     # on the far end would be complicated.
2530     if ($ca{ContentEncoding} and $ca{ContentType}) {
2531         my ($content_col) = grep {exists $ca{$_}} qw/LargeContent Content/;
2532         $store{$content_col} = $self->_DecodeLOB(
2533             "application/octet-stream", # Lie so that we get bytes, not characters
2534             $self->ContentEncoding,
2535             $self->_Value( $content_col, decode_utf8 => 0 )
2536         );
2537         delete $store{ContentEncoding};
2538     }
2539     return %store unless $args{UIDs};
2540
2541     # Use FooObj to turn Foo into a reference to the UID
2542     for my $col ( grep {$store{$_}} @cols ) {
2543         my $method = $methods{$col};
2544         if (not $method) {
2545             $method = $col;
2546             $method =~ s/(Id)?$/Obj/;
2547         }
2548         next unless $self->can($method);
2549
2550         my $obj = $self->$method;
2551         next unless $obj and $obj->isa("RT::Record");
2552         $store{$col} = \($obj->UID);
2553     }
2554
2555     # Anything on an object should get the UID stored instead
2556     if ($store{ObjectType} and $store{ObjectId} and $self->can("Object")) {
2557         delete $store{$_} for qw/ObjectType ObjectId/;
2558         $store{Object} = \($self->Object->UID);
2559     }
2560
2561     return %store;
2562 }
2563
2564 sub PreInflate {
2565     my $class = shift;
2566     my ($importer, $uid, $data) = @_;
2567
2568     my $ca = $class->_ClassAccessible;
2569     my %ca = %{ $ca };
2570
2571     if ($ca{ContentEncoding} and $ca{ContentType}) {
2572         my ($content_col) = grep {exists $ca{$_}} qw/LargeContent Content/;
2573         if (defined $data->{$content_col}) {
2574             my ($ContentEncoding, $Content) = $class->_EncodeLOB(
2575                 $data->{$content_col}, $data->{ContentType},
2576             );
2577             $data->{ContentEncoding} = $ContentEncoding;
2578             $data->{$content_col} = $Content;
2579         }
2580     }
2581
2582     if ($data->{Object} and not $ca{Object}) {
2583         my $ref_uid = ${ delete $data->{Object} };
2584         my $ref = $importer->Lookup( $ref_uid );
2585         if ($ref) {
2586             my ($class, $id) = @{$ref};
2587             $data->{ObjectId} = $id;
2588             $data->{ObjectType} = $class;
2589         } else {
2590             $data->{ObjectId} = 0;
2591             $data->{ObjectType} = "";
2592             $importer->Postpone(
2593                 for => $ref_uid,
2594                 uid => $uid,
2595                 column => "ObjectId",
2596                 classcolumn => "ObjectType",
2597             );
2598         }
2599     }
2600
2601     for my $col (keys %{$data}) {
2602         if (ref $data->{$col}) {
2603             my $ref_uid = ${ $data->{$col} };
2604             my $ref = $importer->Lookup( $ref_uid );
2605             if ($ref) {
2606                 my (undef, $id) = @{$ref};
2607                 $data->{$col} = $id;
2608             } else {
2609                 $data->{$col} = 0;
2610                 $importer->Postpone(
2611                     for => $ref_uid,
2612                     uid => $uid,
2613                     column => $col,
2614                 );
2615             }
2616         }
2617     }
2618
2619     return 1;
2620 }
2621
2622 sub PostInflate {
2623 }
2624
2625 =head2 _AsInsertQuery
2626
2627 Returns INSERT query string that duplicates current record and
2628 can be used to insert record back into DB after delete.
2629
2630 =cut
2631
2632 sub _AsInsertQuery
2633 {
2634     my $self = shift;
2635
2636     my $dbh = $RT::Handle->dbh;
2637
2638     my $res = "INSERT INTO ". $dbh->quote_identifier( $self->Table );
2639     my $values = $self->{'values'};
2640     $res .= "(". join( ",", map { $dbh->quote_identifier( $_ ) } sort keys %$values ) .")";
2641     $res .= " VALUES";
2642     $res .= "(". join( ",", map { $dbh->quote( $values->{$_} ) } sort keys %$values ) .")";
2643     $res .= ";";
2644
2645     return $res;
2646 }
2647
2648 sub BeforeWipeout { return 1 }
2649
2650 =head2 Dependencies
2651
2652 Returns L<RT::Shredder::Dependencies> object.
2653
2654 =cut
2655
2656 sub Dependencies
2657 {
2658     my $self = shift;
2659     my %args = (
2660             Shredder => undef,
2661             Flags => RT::Shredder::Constants::DEPENDS_ON,
2662             @_,
2663            );
2664
2665     unless( $self->id ) {
2666         RT::Shredder::Exception->throw('Object is not loaded');
2667     }
2668
2669     my $deps = RT::Shredder::Dependencies->new();
2670     if( $args{'Flags'} & RT::Shredder::Constants::DEPENDS_ON ) {
2671         $self->__DependsOn( %args, Dependencies => $deps );
2672     }
2673     return $deps;
2674 }
2675
2676 sub __DependsOn
2677 {
2678     my $self = shift;
2679     my %args = (
2680             Shredder => undef,
2681             Dependencies => undef,
2682             @_,
2683            );
2684     my $deps = $args{'Dependencies'};
2685     my $list = [];
2686
2687 # Object custom field values
2688     my $objs = $self->CustomFieldValues;
2689     $objs->{'find_expired_rows'} = 1;
2690     push( @$list, $objs );
2691
2692 # Object attributes
2693     $objs = $self->Attributes;
2694     push( @$list, $objs );
2695
2696 # Transactions
2697     $objs = RT::Transactions->new( $self->CurrentUser );
2698     $objs->Limit( FIELD => 'ObjectType', VALUE => ref $self );
2699     $objs->Limit( FIELD => 'ObjectId', VALUE => $self->id );
2700     push( @$list, $objs );
2701
2702 # Links
2703     if ( $self->can('Links') ) {
2704         # make sure we don't skip any record
2705         no warnings 'redefine';
2706         local *RT::Links::IsValidLink = sub { 1 };
2707
2708         foreach ( qw(Base Target) ) {
2709             my $objs = $self->Links( $_ );
2710             $objs->_DoSearch;
2711             push @$list, $objs->ItemsArrayRef;
2712         }
2713     }
2714
2715 # ACE records
2716     $objs = RT::ACL->new( $self->CurrentUser );
2717     $objs->LimitToObject( $self );
2718     push( @$list, $objs );
2719
2720     $deps->_PushDependencies(
2721             BaseObject => $self,
2722             Flags => RT::Shredder::Constants::DEPENDS_ON,
2723             TargetObjects => $list,
2724             Shredder => $args{'Shredder'}
2725         );
2726     return;
2727 }
2728
2729 # implement proxy method because some RT classes
2730 # override Delete method
2731 sub __Wipeout
2732 {
2733     my $self = shift;
2734     my $msg = $self->UID ." wiped out";
2735     $self->SUPER::Delete;
2736     $RT::Logger->info( $msg );
2737     return;
2738 }
2739
2740 RT::Base->_ImportOverlays();
2741
2742 1;