rt/lib/RT/Record.pm

   1 # BEGIN BPS TAGGED BLOCK {{{
   2 #
   3 # COPYRIGHT:
   4 #
   5 # This software is Copyright (c) 1996-2017 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       for my $fstable (qw(cust_main cust_svc)) {
1286
1287         $self->{'Customers'}->Limit(
1288                                      FIELD    => 'Target',
1289                                      OPERATOR => 'STARTSWITH',
1290                                      VALUE    => "freeside://freeside/$fstable",
1291                                      ENTRYAGGREGATOR => 'OR',
1292                                      SUBCLAUSE => 'customers',
1293                                    );
1294       }
1295     }
1296
1297     warn "->Customers method called on $self; returning ".
1298          ref($self->{'Customers'}). ' object'
1299       if $Debug;
1300
1301     return $self->{'Customers'};
1302 }
1303
1304 # }}}
1305
1306 # {{{ Services
1307
1308 =head2 Services
1309
1310   This returns an RT::Links object which references all the services this
1311   object is a member of.
1312
1313 =cut
1314
1315 sub Services {
1316     my( $self, %opt ) = @_;
1317
1318     unless ( $self->{'Services'} ) {
1319
1320       $self->{'Services'} = $self->MemberOf->Clone;
1321
1322       $self->{'Services'}->Limit(
1323                                    FIELD    => 'Target',
1324                                    OPERATOR => 'STARTSWITH',
1325                                    VALUE    => "freeside://freeside/cust_svc",
1326                                  );
1327     }
1328
1329     return $self->{'Services'};
1330 }
1331
1332
1333
1334
1335
1336
1337 =head2 Links DIRECTION [TYPE]
1338
1339 Return links (L<RT::Links>) to/from this object.
1340
1341 DIRECTION is either 'Base' or 'Target'.
1342
1343 TYPE is a type of links to return, it can be omitted to get
1344 links of any type.
1345
1346 =cut
1347
1348 sub Links { shift->_Links(@_) }
1349
1350 sub _Links {
1351     my $self = shift;
1352
1353     #TODO: Field isn't the right thing here. but I ahave no idea what mnemonic ---
1354     #tobias meant by $f
1355     my $field = shift;
1356     my $type  = shift || "";
1357
1358     unless ( $self->{"$field$type"} ) {
1359         $self->{"$field$type"} = RT::Links->new( $self->CurrentUser );
1360             # at least to myself
1361             $self->{"$field$type"}->Limit( FIELD => $field,
1362                                            VALUE => $self->URI,
1363                                            ENTRYAGGREGATOR => 'OR' );
1364             $self->{"$field$type"}->Limit( FIELD => 'Type',
1365                                            VALUE => $type )
1366               if ($type);
1367     }
1368     return ( $self->{"$field$type"} );
1369 }
1370
1371
1372
1373
1374 =head2 FormatType
1375
1376 Takes a Type and returns a string that is more human readable.
1377
1378 =cut
1379
1380 sub FormatType{
1381     my $self = shift;
1382     my %args = ( Type => '',
1383                  @_
1384                );
1385     $args{Type} =~ s/([A-Z])/" " . lc $1/ge;
1386     $args{Type} =~ s/^\s+//;
1387     return $args{Type};
1388 }
1389
1390
1391
1392
1393 =head2 FormatLink
1394
1395 Takes either a Target or a Base and returns a string of human friendly text.
1396
1397 =cut
1398
1399 sub FormatLink {
1400     my $self = shift;
1401     my %args = ( Object => undef,
1402                  FallBack => '',
1403                  @_
1404                );
1405     my $text = "URI " . $args{FallBack};
1406     if ($args{Object} && $args{Object}->isa("RT::Ticket")) {
1407         $text = "Ticket " . $args{Object}->id;
1408     }
1409     return $text;
1410 }
1411
1412 =head2 _AddLink
1413
1414 Takes a paramhash of Type and one of Base or Target. Adds that link to this object.
1415
1416 If Silent is true then no transactions will be recorded.  You can individually
1417 control transactions on both base and target and with SilentBase and
1418 SilentTarget respectively. By default both transactions are created.
1419
1420 If the link destination is a local object and does the
1421 L<RT::Record::Role::Status> role, this method ensures object Status is not
1422 "deleted".  Linking to deleted objects is forbidden.
1423
1424 If the link destination (i.e. not C<$self>) is a local object and the
1425 C<$StrictLinkACL> option is enabled, this method checks the appropriate right
1426 on the destination object (if any, as returned by the L</ModifyLinkRight>
1427 method).  B<< The subclass is expected to check the appropriate right on the
1428 source object (i.e.  C<$self>) before calling this method. >>  This allows a
1429 different right to be used on the source object during creation, for example.
1430
1431 Returns a tuple of (link ID, message, flag if link already existed).
1432
1433 =cut
1434
1435 sub _AddLink {
1436     my $self = shift;
1437     my %args = (
1438         Target       => '',
1439         Base         => '',
1440         Type         => '',
1441         Silent       => undef,
1442         Silent       => undef,
1443         SilentBase   => undef,
1444         SilentTarget => undef,
1445         @_
1446     );
1447
1448     # Remote_link is the URI of the object that is not this ticket
1449     my $remote_link;
1450     my $direction;
1451
1452     if ( $args{'Base'} and $args{'Target'} ) {
1453         $RT::Logger->debug( "$self tried to create a link. both base and target were specified" );
1454         return ( 0, $self->loc("Can't specify both base and target") );
1455     }
1456     elsif ( $args{'Base'} ) {
1457         $args{'Target'} = $self->URI();
1458         $remote_link    = $args{'Base'};
1459         $direction      = 'Target';
1460     }
1461     elsif ( $args{'Target'} ) {
1462         $args{'Base'} = $self->URI();
1463         $remote_link  = $args{'Target'};
1464         $direction    = 'Base';
1465     }
1466     else {
1467         return ( 0, $self->loc('Either base or target must be specified') );
1468     }
1469
1470     my $remote_uri = RT::URI->new( $self->CurrentUser );
1471     if ($remote_uri->FromURI( $remote_link )) {
1472         my $remote_obj = $remote_uri->IsLocal ? $remote_uri->Object : undef;
1473         if ($remote_obj and $remote_obj->id) {
1474             # Enforce the remote end of StrictLinkACL
1475             if (RT->Config->Get("StrictLinkACL")) {
1476                 my $right = $remote_obj->ModifyLinkRight;
1477
1478                 return (0, $self->loc("Permission denied"))
1479                     if $right and
1480                    not $self->CurrentUser->HasRight( Right => $right, Object => $remote_obj );
1481             }
1482
1483             # Prevent linking to deleted objects
1484             if ($remote_obj->DOES("RT::Record::Role::Status")
1485                 and $remote_obj->Status eq "deleted") {
1486                 return (0, $self->loc("Linking to a deleted [_1] is not allowed", $self->loc(lc($remote_obj->RecordType))));
1487             }
1488         }
1489     } else {
1490         return (0, $self->loc("Couldn't resolve '[_1]' into a link.", $remote_link));
1491     }
1492
1493     # Check if the link already exists - we don't want duplicates
1494     my $old_link = RT::Link->new( $self->CurrentUser );
1495     $old_link->LoadByParams( Base   => $args{'Base'},
1496                              Type   => $args{'Type'},
1497                              Target => $args{'Target'} );
1498     if ( $old_link->Id ) {
1499         $RT::Logger->debug("$self Somebody tried to duplicate a link");
1500         return ( $old_link->id, $self->loc("Link already exists"), 1 );
1501     }
1502
1503     if ( $args{'Type'} =~ /^(?:DependsOn|MemberOf)$/ ) {
1504
1505         my @tickets = $self->_AllLinkedTickets(
1506             LinkType  => $args{'Type'},
1507             Direction => $direction eq 'Target' ? 'Base' : 'Target',
1508         );
1509         if ( grep { $_->id == ( $direction eq 'Target' ? $args{'Base'} : $args{'Target'} ) } @tickets ) {
1510             return ( 0, $self->loc("Refused to add link which would create a circular relationship") );
1511         }
1512     }
1513
1514     # Storing the link in the DB.
1515     my $link = RT::Link->new( $self->CurrentUser );
1516     my ($linkid, $linkmsg) = $link->Create( Target => $args{Target},
1517                                             Base   => $args{Base},
1518                                             Type   => $args{Type} );
1519
1520     unless ($linkid) {
1521         $RT::Logger->error("Link could not be created: ".$linkmsg);
1522         return ( 0, $self->loc("Link could not be created: [_1]", $linkmsg) );
1523     }
1524
1525     my $basetext = $self->FormatLink(Object   => $link->BaseObj,
1526                                      FallBack => $args{Base});
1527     my $targettext = $self->FormatLink(Object   => $link->TargetObj,
1528                                        FallBack => $args{Target});
1529     my $typetext = $self->FormatType(Type => $args{Type});
1530     my $TransString = "$basetext $typetext $targettext.";
1531
1532     # No transactions for you!
1533     return ($linkid, $TransString) if $args{'Silent'};
1534
1535     my $opposite_direction = $direction eq 'Target' ? 'Base': 'Target';
1536
1537     # Some transactions?
1538     unless ( $args{ 'Silent'. $direction } ) {
1539         my ( $Trans, $Msg, $TransObj ) = $self->_NewTransaction(
1540             Type      => 'AddLink',
1541             Field     => $RT::Link::DIRMAP{$args{'Type'}}->{$direction},
1542             NewValue  => $remote_uri->URI || $remote_link,
1543             TimeTaken => 0
1544         );
1545         $RT::Logger->error("Couldn't create transaction: $Msg") unless $Trans;
1546     }
1547
1548     if ( !$args{"Silent$opposite_direction"} && $remote_uri->IsLocal ) {
1549         my $OtherObj = $remote_uri->Object;
1550         my ( $val, $msg ) = $OtherObj->_NewTransaction(
1551             Type           => 'AddLink',
1552             Field          => $RT::Link::DIRMAP{$args{'Type'}}->{$opposite_direction},
1553             NewValue       => $self->URI,
1554             TimeTaken      => 0,
1555         );
1556         $RT::Logger->error("Couldn't create transaction: $msg") unless $val;
1557     }
1558
1559     return ($linkid, $TransString);
1560 }
1561
1562 =head2 _DeleteLink
1563
1564 Takes a paramhash of Type and one of Base or Target. Removes that link from this object.
1565
1566 If Silent is true then no transactions will be recorded.  You can individually
1567 control transactions on both base and target and with SilentBase and
1568 SilentTarget respectively. By default both transactions are created.
1569
1570 If the link destination (i.e. not C<$self>) is a local object and the
1571 C<$StrictLinkACL> option is enabled, this method checks the appropriate right
1572 on the destination object (if any, as returned by the L</ModifyLinkRight>
1573 method).  B<< The subclass is expected to check the appropriate right on the
1574 source object (i.e.  C<$self>) before calling this method. >>
1575
1576 Returns a tuple of (status flag, message).
1577
1578 =cut
1579
1580 sub _DeleteLink {
1581     my $self = shift;
1582     my %args = (
1583         Base         => undef,
1584         Target       => undef,
1585         Type         => undef,
1586         Silent       => undef,
1587         SilentBase   => undef,
1588         SilentTarget => undef,
1589         @_
1590     );
1591
1592     # We want one of base and target. We don't care which but we only want _one_.
1593     my $direction;
1594     my $remote_link;
1595
1596     if ( $args{'Base'} and $args{'Target'} ) {
1597         $RT::Logger->debug("$self ->_DeleteLink. got both Base and Target");
1598         return ( 0, $self->loc("Can't specify both base and target") );
1599     }
1600     elsif ( $args{'Base'} ) {
1601         $args{'Target'} = $self->URI();
1602         $remote_link    = $args{'Base'};
1603         $direction      = 'Target';
1604     }
1605     elsif ( $args{'Target'} ) {
1606         $args{'Base'} = $self->URI();
1607         $remote_link  = $args{'Target'};
1608         $direction    = 'Base';
1609     }
1610     else {
1611         $RT::Logger->error("Base or Target must be specified");
1612         return ( 0, $self->loc('Either base or target must be specified') );
1613     }
1614
1615     my $remote_uri = RT::URI->new( $self->CurrentUser );
1616     if ($remote_uri->FromURI( $remote_link )) {
1617         # Enforce the remote end of StrictLinkACL
1618         my $remote_obj = $remote_uri->IsLocal ? $remote_uri->Object : undef;
1619         if ($remote_obj and $remote_obj->id and RT->Config->Get("StrictLinkACL")) {
1620             my $right = $remote_obj->ModifyLinkRight;
1621
1622             return (0, $self->loc("Permission denied"))
1623                 if $right and
1624                not $self->CurrentUser->HasRight( Right => $right, Object => $remote_obj );
1625         }
1626     } else {
1627         return (0, $self->loc("Couldn't resolve '[_1]' into a link.", $remote_link));
1628     }
1629
1630     my $link = RT::Link->new( $self->CurrentUser );
1631     $RT::Logger->debug( "Trying to load link: "
1632             . $args{'Base'} . " "
1633             . $args{'Type'} . " "
1634             . $args{'Target'} );
1635
1636     $link->LoadByParams(
1637         Base   => $args{'Base'},
1638         Type   => $args{'Type'},
1639         Target => $args{'Target'}
1640     );
1641
1642     unless ($link->id) {
1643         $RT::Logger->debug("Couldn't find that link");
1644         return ( 0, $self->loc("Link not found") );
1645     }
1646
1647     my $basetext = $self->FormatLink(Object   => $link->BaseObj,
1648                                      FallBack => $args{Base});
1649     my $targettext = $self->FormatLink(Object   => $link->TargetObj,
1650                                        FallBack => $args{Target});
1651     my $typetext = $self->FormatType(Type => $args{Type});
1652     my $TransString = "$basetext no longer $typetext $targettext.";
1653
1654     my ($ok, $msg) = $link->Delete();
1655     unless ($ok) {
1656         RT->Logger->error("Link could not be deleted: $msg");
1657         return ( 0, $self->loc("Link could not be deleted: [_1]", $msg) );
1658     }
1659
1660     # No transactions for you!
1661     return (1, $TransString) if $args{'Silent'};
1662
1663     my $opposite_direction = $direction eq 'Target' ? 'Base': 'Target';
1664
1665     # Some transactions?
1666     unless ( $args{ 'Silent'. $direction } ) {
1667         my ( $Trans, $Msg, $TransObj ) = $self->_NewTransaction(
1668             Type      => 'DeleteLink',
1669             Field     => $RT::Link::DIRMAP{$args{'Type'}}->{$direction},
1670             OldValue  => $remote_uri->URI || $remote_link,
1671             TimeTaken => 0
1672         );
1673         $RT::Logger->error("Couldn't create transaction: $Msg") unless $Trans;
1674     }
1675
1676     if ( !$args{"Silent$opposite_direction"} && $remote_uri->IsLocal ) {
1677         my $OtherObj = $remote_uri->Object;
1678         my ( $val, $msg ) = $OtherObj->_NewTransaction(
1679             Type           => 'DeleteLink',
1680             Field          => $RT::Link::DIRMAP{$args{'Type'}}->{$opposite_direction},
1681             OldValue       => $self->URI,
1682             TimeTaken      => 0,
1683         );
1684         $RT::Logger->error("Couldn't create transaction: $msg") unless $val;
1685     }
1686
1687     return (1, $TransString);
1688 }
1689
1690 =head1 LockForUpdate
1691
1692 In a database transaction, gains an exclusive lock on the row, to
1693 prevent race conditions.  On SQLite, this is a "RESERVED" lock on the
1694 entire database.
1695
1696 =cut
1697
1698 sub LockForUpdate {
1699     my $self = shift;
1700
1701     my $pk = $self->_PrimaryKey;
1702     my $id = @_ ? $_[0] : $self->$pk;
1703     $self->_expire if $self->isa("DBIx::SearchBuilder::Record::Cachable");
1704     if (RT->Config->Get('DatabaseType') eq "SQLite") {
1705         # SQLite does DB-level locking, upgrading the transaction to
1706         # "RESERVED" on the first UPDATE/INSERT/DELETE.  Do a no-op
1707         # UPDATE to force the upgade.
1708         return RT->DatabaseHandle->dbh->do(
1709             "UPDATE " .$self->Table.
1710                 " SET $pk = $pk WHERE 1 = 0");
1711     } else {
1712         return $self->_LoadFromSQL(
1713             "SELECT * FROM ".$self->Table
1714                 ." WHERE $pk = ? FOR UPDATE",
1715             $id,
1716         );
1717     }
1718 }
1719
1720 =head2 _NewTransaction  PARAMHASH
1721
1722 Private function to create a new RT::Transaction object for this ticket update
1723
1724 =cut
1725
1726 sub _NewTransaction {
1727     my $self = shift;
1728     my %args = (
1729         TimeTaken => undef,
1730         Type      => undef,
1731         OldValue  => undef,
1732         NewValue  => undef,
1733         OldReference  => undef,
1734         NewReference  => undef,
1735         ReferenceType => undef,
1736         Data      => undef,
1737         Field     => undef,
1738         MIMEObj   => undef,
1739         ActivateScrips => 1,
1740         CommitScrips => 1,
1741         SquelchMailTo => undef,
1742         CustomFields => {},
1743         @_
1744     );
1745
1746     my $in_txn = RT->DatabaseHandle->TransactionDepth;
1747     RT->DatabaseHandle->BeginTransaction unless $in_txn;
1748
1749     $self->LockForUpdate;
1750
1751     my $old_ref = $args{'OldReference'};
1752     my $new_ref = $args{'NewReference'};
1753     my $ref_type = $args{'ReferenceType'};
1754     if ($old_ref or $new_ref) {
1755         $ref_type ||= ref($old_ref) || ref($new_ref);
1756         if (!$ref_type) {
1757             $RT::Logger->error("Reference type not specified for transaction");
1758             return;
1759         }
1760         $old_ref = $old_ref->Id if ref($old_ref);
1761         $new_ref = $new_ref->Id if ref($new_ref);
1762     }
1763
1764     require RT::Transaction;
1765     my $trans = RT::Transaction->new( $self->CurrentUser );
1766     my ( $transaction, $msg ) = $trans->Create(
1767         ObjectId  => $self->Id,
1768         ObjectType => ref($self),
1769         TimeTaken => $args{'TimeTaken'},
1770         Type      => $args{'Type'},
1771         Data      => $args{'Data'},
1772         Field     => $args{'Field'},
1773         NewValue  => $args{'NewValue'},
1774         OldValue  => $args{'OldValue'},
1775         NewReference  => $new_ref,
1776         OldReference  => $old_ref,
1777         ReferenceType => $ref_type,
1778         MIMEObj   => $args{'MIMEObj'},
1779         ActivateScrips => $args{'ActivateScrips'},
1780         CommitScrips => $args{'CommitScrips'},
1781         SquelchMailTo => $args{'SquelchMailTo'},
1782         CustomFields => $args{'CustomFields'},
1783     );
1784
1785     # Rationalize the object since we may have done things to it during the caching.
1786     $self->Load($self->Id);
1787
1788     $RT::Logger->warning($msg) unless $transaction;
1789
1790     $self->_SetLastUpdated;
1791
1792     if ( defined $args{'TimeTaken'} and $self->can('_UpdateTimeTaken')) {
1793         $self->_UpdateTimeTaken( $args{'TimeTaken'}, Transaction => $trans );
1794     }
1795     if ( RT->Config->Get('UseTransactionBatch') and $transaction ) {
1796             push @{$self->{_TransactionBatch}}, $trans if $args{'CommitScrips'};
1797     }
1798
1799     RT->DatabaseHandle->Commit unless $in_txn;
1800
1801     return ( $transaction, $msg, $trans );
1802 }
1803
1804
1805
1806 =head2 Transactions
1807
1808 Returns an L<RT::Transactions> object of all transactions on this record object
1809
1810 =cut
1811
1812 sub Transactions {
1813     my $self = shift;
1814
1815     my $transactions = RT::Transactions->new( $self->CurrentUser );
1816     $transactions->Limit(
1817         FIELD => 'ObjectId',
1818         VALUE => $self->id,
1819     );
1820     $transactions->Limit(
1821         FIELD => 'ObjectType',
1822         VALUE => ref($self),
1823     );
1824
1825     return $transactions;
1826 }
1827
1828 =head2 SortedTransactions
1829
1830 Returns the result of L</Transactions> ordered per the
1831 I<OldestTransactionsFirst> preference/option.
1832
1833 =cut
1834
1835 sub SortedTransactions {
1836     my $self  = shift;
1837     my $txns  = $self->Transactions;
1838     my $order = RT->Config->Get("OldestTransactionsFirst", $self->CurrentUser)
1839         ? 'ASC' : 'DESC';
1840     $txns->OrderByCols(
1841         { FIELD => 'Created',   ORDER => $order },
1842         { FIELD => 'id',        ORDER => $order },
1843     );
1844     return $txns;
1845 }
1846
1847 our %TRANSACTION_CLASSIFICATION = (
1848     Create     => 'message',
1849     Correspond => 'message',
1850     Comment    => 'message',
1851
1852     AddWatcher => 'people',
1853     DelWatcher => 'people',
1854
1855     Take       => 'people',
1856     Untake     => 'people',
1857     Force      => 'people',
1858     Steal      => 'people',
1859     Give       => 'people',
1860
1861     AddLink    => 'links',
1862     DeleteLink => 'links',
1863
1864     Status     => 'basics',
1865     Set        => {
1866         __default => 'basics',
1867         map( { $_ => 'dates' } qw(
1868             Told Starts Started Due LastUpdated Created LastUpdated
1869         ) ),
1870         map( { $_ => 'people' } qw(
1871             Owner Creator LastUpdatedBy
1872         ) ),
1873     },
1874     SystemError => 'error',
1875     AttachmentTruncate => 'attachment-truncate',
1876     AttachmentDrop => 'attachment-drop',
1877     AttachmentError => 'error',
1878     __default => 'other',
1879 );
1880
1881 sub ClassifyTransaction {
1882     my $self = shift;
1883     my $txn = shift;
1884
1885     my $type = $txn->Type;
1886
1887     my $res = $TRANSACTION_CLASSIFICATION{ $type };
1888     return $res || $TRANSACTION_CLASSIFICATION{ '__default' }
1889         unless ref $res;
1890
1891     return $res->{ $txn->Field } || $res->{'__default'}
1892         || $TRANSACTION_CLASSIFICATION{ '__default' };
1893 }
1894
1895 =head2 Attachments
1896
1897 Returns an L<RT::Attachments> object of all attachments on this record object
1898 (for all its L</Transactions>).
1899
1900 By default Content and Headers of attachments are not fetched right away from
1901 database. Use C<WithContent> and C<WithHeaders> options to override this.
1902
1903 =cut
1904
1905 sub Attachments {
1906     my $self = shift;
1907     my %args = (
1908         WithHeaders => 0,
1909         WithContent => 0,
1910         @_
1911     );
1912     my @columns = grep { not /^(Headers|Content)$/ }
1913                        RT::Attachment->ReadableAttributes;
1914     push @columns, 'Headers' if $args{'WithHeaders'};
1915     push @columns, 'Content' if $args{'WithContent'};
1916
1917     my $res = RT::Attachments->new( $self->CurrentUser );
1918     $res->Columns( @columns );
1919     my $txn_alias = $res->TransactionAlias;
1920     $res->Limit(
1921         ALIAS => $txn_alias,
1922         FIELD => 'ObjectType',
1923         VALUE => ref($self),
1924     );
1925     $res->Limit(
1926         ALIAS => $txn_alias,
1927         FIELD => 'ObjectId',
1928         VALUE => $self->id,
1929     );
1930     return $res;
1931 }
1932
1933 =head2 TextAttachments
1934
1935 Returns an L<RT::Attachments> object of all attachments, like L<Attachments>,
1936 but only those that are text.
1937
1938 By default Content and Headers are fetched. Use C<WithContent> and
1939 C<WithHeaders> options to override this.
1940
1941 =cut
1942
1943 sub TextAttachments {
1944     my $self = shift;
1945     my $res = $self->Attachments(
1946         WithHeaders => 1,
1947         WithContent => 1,
1948         @_
1949     );
1950     $res->Limit( FIELD => 'ContentType', OPERATOR => '=', VALUE => 'text/plain');
1951     $res->Limit( FIELD => 'ContentType', OPERATOR => 'STARTSWITH', VALUE => 'message/');
1952     $res->Limit( FIELD => 'ContentType', OPERATOR => '=', VALUE => 'text');
1953     $res->Limit( FIELD => 'Filename', OPERATOR => 'IS', VALUE => 'NULL')
1954         if RT->Config->Get( 'SuppressInlineTextFiles', $self->CurrentUser );
1955     return $res;
1956 }
1957
1958 sub CustomFields {
1959     my $self = shift;
1960     my $cfs  = RT::CustomFields->new( $self->CurrentUser );
1961
1962     $cfs->SetContextObject( $self );
1963     # XXX handle multiple types properly
1964     $cfs->LimitToLookupType( $self->CustomFieldLookupType );
1965     $cfs->LimitToGlobalOrObjectId( $self->CustomFieldLookupId );
1966     $cfs->ApplySortOrder;
1967
1968     return $cfs;
1969 }
1970
1971 # TODO: This _only_ works for RT::Foo classes. it doesn't work, for
1972 # example, for RT::IR::Foo classes.
1973
1974 sub CustomFieldLookupId {
1975     my $self = shift;
1976     my $lookup = shift || $self->CustomFieldLookupType;
1977     my @classes = ($lookup =~ /RT::(\w+)-/g);
1978
1979     # Work on "RT::Queue", for instance
1980     return $self->Id unless @classes;
1981
1982     my $object = $self;
1983     # Save a ->Load call by not calling ->FooObj->Id, just ->Foo
1984     my $final = shift @classes;
1985     foreach my $class (reverse @classes) {
1986         my $method = "${class}Obj";
1987         $object = $object->$method;
1988     }
1989
1990     my $id = $object->$final;
1991     unless (defined $id) {
1992         my $method = "${final}Obj";
1993         $id = $object->$method->Id;
1994     }
1995     return $id;
1996 }
1997
1998
1999 =head2 CustomFieldLookupType
2000
2001 Returns the path RT uses to figure out which custom fields apply to this object.
2002
2003 =cut
2004
2005 sub CustomFieldLookupType {
2006     my $self = shift;
2007     return ref($self) || $self;
2008 }
2009
2010
2011 =head2 AddCustomFieldValue { Field => FIELD, Value => VALUE }
2012
2013 VALUE should be a string. FIELD can be any identifier of a CustomField
2014 supported by L</LoadCustomFieldByIdentifier> method.
2015
2016 Adds VALUE as a value of CustomField FIELD. If this is a single-value custom field,
2017 deletes the old value.
2018 If VALUE is not a valid value for the custom field, returns
2019 (0, 'Error message' ) otherwise, returns ($id, 'Success Message') where
2020 $id is ID of created L<ObjectCustomFieldValue> object.
2021
2022 =cut
2023
2024 sub AddCustomFieldValue {
2025     my $self = shift;
2026     $self->_AddCustomFieldValue(@_);
2027 }
2028
2029 sub _AddCustomFieldValue {
2030     my $self = shift;
2031     my %args = (
2032         Field             => undef,
2033         Value             => undef,
2034         LargeContent      => undef,
2035         ContentType       => undef,
2036         RecordTransaction => 1,
2037         @_
2038     );
2039
2040     my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
2041     unless ( $cf->Id ) {
2042         return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
2043     }
2044
2045     my $OCFs = $self->CustomFields;
2046     $OCFs->Limit( FIELD => 'id', VALUE => $cf->Id );
2047     unless ( $OCFs->Count ) {
2048         return (
2049             0,
2050             $self->loc(
2051                 "Custom field [_1] does not apply to this object",
2052                 ref $args{'Field'} ? $args{'Field'}->id : $args{'Field'}
2053             )
2054         );
2055     }
2056
2057     # empty string is not correct value of any CF, so undef it
2058     foreach ( qw(Value LargeContent) ) {
2059         $args{ $_ } = undef if defined $args{ $_ } && !length $args{ $_ };
2060     }
2061
2062     unless ( $cf->ValidateValue( $args{'Value'} ) ) {
2063         return ( 0, $self->loc("Invalid value for custom field") );
2064     }
2065
2066     # If the custom field only accepts a certain # of values, delete the existing
2067     # value and record a "changed from foo to bar" transaction
2068     unless ( $cf->UnlimitedValues ) {
2069
2070         # Load up a ObjectCustomFieldValues object for this custom field and this ticket
2071         my $values = $cf->ValuesForObject($self);
2072
2073         # We need to whack any old values here.  In most cases, the custom field should
2074         # only have one value to delete.  In the pathalogical case, this custom field
2075         # used to be a multiple and we have many values to whack....
2076         my $cf_values = $values->Count;
2077
2078         if ( $cf_values > $cf->MaxValues ) {
2079             my $i = 0;   #We want to delete all but the max we can currently have , so we can then
2080                  # execute the same code to "change" the value from old to new
2081             while ( my $value = $values->Next ) {
2082                 $i++;
2083                 if ( $i < $cf_values ) {
2084                     my ( $val, $msg ) = $cf->DeleteValueForObject(
2085                         Object => $self,
2086                         Id     => $value->id,
2087                     );
2088                     unless ($val) {
2089                         return ( 0, $msg );
2090                     }
2091                     my ( $TransactionId, $Msg, $TransactionObj ) =
2092                       $self->_NewTransaction(
2093                         Type         => 'CustomField',
2094                         Field        => $cf->Id,
2095                         OldReference => $value,
2096                       );
2097                 }
2098             }
2099             $values->RedoSearch if $i; # redo search if have deleted at least one value
2100         }
2101
2102         if ( my $entry = $values->HasEntry($args{'Value'}, $args{'LargeContent'}) ) {
2103             return $entry->id;
2104         }
2105
2106         my $old_value = $values->First;
2107         my $old_content;
2108         $old_content = $old_value->Content if $old_value;
2109
2110         my ( $new_value_id, $value_msg ) = $cf->AddValueForObject(
2111             Object       => $self,
2112             Content      => $args{'Value'},
2113             LargeContent => $args{'LargeContent'},
2114             ContentType  => $args{'ContentType'},
2115         );
2116
2117         unless ( $new_value_id ) {
2118             return ( 0, $self->loc( "Could not add new custom field value: [_1]", $value_msg ) );
2119         }
2120
2121         my $new_value = RT::ObjectCustomFieldValue->new( $self->CurrentUser );
2122         $new_value->Load( $new_value_id );
2123
2124         # now that adding the new value was successful, delete the old one
2125         if ( $old_value ) {
2126             my ( $val, $msg ) = $old_value->Delete();
2127             return ( 0, $msg ) unless $val;
2128         }
2129
2130         if ( $args{'RecordTransaction'} ) {
2131             my ( $TransactionId, $Msg, $TransactionObj ) =
2132               $self->_NewTransaction(
2133                 Type         => 'CustomField',
2134                 Field        => $cf->Id,
2135                 OldReference => $old_value,
2136                 NewReference => $new_value,
2137               );
2138         }
2139
2140         my $new_content = $new_value->Content;
2141
2142         # For datetime, we need to display them in "human" format in result message
2143         #XXX TODO how about date without time?
2144         if ($cf->Type eq 'DateTime') {
2145             my $DateObj = RT::Date->new( $self->CurrentUser );
2146             $DateObj->Set(
2147                 Format => 'ISO',
2148                 Value  => $new_content,
2149             );
2150             $new_content = $DateObj->AsString;
2151
2152             if ( defined $old_content && length $old_content ) {
2153                 $DateObj->Set(
2154                     Format => 'ISO',
2155                     Value  => $old_content,
2156                 );
2157                 $old_content = $DateObj->AsString;
2158             }
2159         }
2160
2161         unless ( defined $old_content && length $old_content ) {
2162             return ( $new_value_id, $self->loc( "[_1] [_2] added", $cf->Name, $new_content ));
2163         }
2164         elsif ( !defined $new_content || !length $new_content ) {
2165             return ( $new_value_id,
2166                 $self->loc( "[_1] [_2] deleted", $cf->Name, $old_content ) );
2167         }
2168         else {
2169             return ( $new_value_id, $self->loc( "[_1] [_2] changed to [_3]", $cf->Name, $old_content, $new_content));
2170         }
2171
2172     }
2173
2174     # otherwise, just add a new value and record "new value added"
2175     else {
2176         my $values = $cf->ValuesForObject($self);
2177         if ( my $entry = $values->HasEntry($args{'Value'}, $args{'LargeContent'}) ) {
2178             return $entry->id;
2179         }
2180
2181         my ($new_value_id, $msg) = $cf->AddValueForObject(
2182             Object       => $self,
2183             Content      => $args{'Value'},
2184             LargeContent => $args{'LargeContent'},
2185             ContentType  => $args{'ContentType'},
2186         );
2187
2188         unless ( $new_value_id ) {
2189             return ( 0, $self->loc( "Could not add new custom field value: [_1]", $msg ) );
2190         }
2191         if ( $args{'RecordTransaction'} ) {
2192             my ( $tid, $msg ) = $self->_NewTransaction(
2193                 Type          => 'CustomField',
2194                 Field         => $cf->Id,
2195                 NewReference  => $new_value_id,
2196                 ReferenceType => 'RT::ObjectCustomFieldValue',
2197             );
2198             unless ( $tid ) {
2199                 return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $msg ) );
2200             }
2201         }
2202         return ( $new_value_id, $self->loc( "[_1] added as a value for [_2]", $args{'Value'}, $cf->Name ) );
2203     }
2204 }
2205
2206
2207
2208 =head2 DeleteCustomFieldValue { Field => FIELD, Value => VALUE }
2209
2210 Deletes VALUE as a value of CustomField FIELD.
2211
2212 VALUE can be a string, a CustomFieldValue or a ObjectCustomFieldValue.
2213
2214 If VALUE is not a valid value for the custom field, returns
2215 (0, 'Error message' ) otherwise, returns (1, 'Success Message')
2216
2217 =cut
2218
2219 sub DeleteCustomFieldValue {
2220     my $self = shift;
2221     my %args = (
2222         Field   => undef,
2223         Value   => undef,
2224         ValueId => undef,
2225         @_
2226     );
2227
2228     my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
2229     unless ( $cf->Id ) {
2230         return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
2231     }
2232
2233     my ( $val, $msg ) = $cf->DeleteValueForObject(
2234         Object  => $self,
2235         Id      => $args{'ValueId'},
2236         Content => $args{'Value'},
2237     );
2238     unless ($val) {
2239         return ( 0, $msg );
2240     }
2241
2242     my ( $TransactionId, $Msg, $TransactionObj ) = $self->_NewTransaction(
2243         Type          => 'CustomField',
2244         Field         => $cf->Id,
2245         OldReference  => $val,
2246         ReferenceType => 'RT::ObjectCustomFieldValue',
2247     );
2248     unless ($TransactionId) {
2249         return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $Msg ) );
2250     }
2251
2252     my $old_value = $TransactionObj->OldValue;
2253     # For datetime, we need to display them in "human" format in result message
2254     if ( $cf->Type eq 'DateTime' ) {
2255         my $DateObj = RT::Date->new( $self->CurrentUser );
2256         $DateObj->Set(
2257             Format => 'ISO',
2258             Value  => $old_value,
2259         );
2260         $old_value = $DateObj->AsString;
2261     }
2262     return (
2263         $TransactionId,
2264         $self->loc(
2265             "[_1] is no longer a value for custom field [_2]",
2266             $old_value, $cf->Name
2267         )
2268     );
2269 }
2270
2271
2272
2273 =head2 FirstCustomFieldValue FIELD
2274
2275 Return the content of the first value of CustomField FIELD for this ticket
2276 Takes a field id or name
2277
2278 =cut
2279
2280 sub FirstCustomFieldValue {
2281     my $self = shift;
2282     my $field = shift;
2283
2284     my $values = $self->CustomFieldValues( $field );
2285     return undef unless my $first = $values->First;
2286     return $first->Content;
2287 }
2288
2289 =head2 CustomFieldValuesAsString FIELD
2290
2291 Return the content of the CustomField FIELD for this ticket.
2292 If this is a multi-value custom field, values will be joined with newlines.
2293
2294 Takes a field id or name as the first argument
2295
2296 Takes an optional Separator => "," second and third argument
2297 if you want to join the values using something other than a newline
2298
2299 =cut
2300
2301 sub CustomFieldValuesAsString {
2302     my $self  = shift;
2303     my $field = shift;
2304     my %args  = @_;
2305     my $separator = $args{Separator} || "\n";
2306
2307     my $values = $self->CustomFieldValues( $field );
2308     return join ($separator, grep { defined $_ }
2309                  map { $_->Content } @{$values->ItemsArrayRef});
2310 }
2311
2312
2313
2314 =head2 CustomFieldValues FIELD
2315
2316 Return a ObjectCustomFieldValues object of all values of the CustomField whose
2317 id or Name is FIELD for this record.
2318
2319 Returns an RT::ObjectCustomFieldValues object
2320
2321 =cut
2322
2323 sub CustomFieldValues {
2324     my $self  = shift;
2325     my $field = shift;
2326
2327     if ( $field ) {
2328         my $cf = $self->LoadCustomFieldByIdentifier( $field );
2329
2330         # we were asked to search on a custom field we couldn't find
2331         unless ( $cf->id ) {
2332             $RT::Logger->warning("Couldn't load custom field by '$field' identifier");
2333             return RT::ObjectCustomFieldValues->new( $self->CurrentUser );
2334         }
2335         return ( $cf->ValuesForObject($self) );
2336     }
2337
2338     # we're not limiting to a specific custom field;
2339     my $ocfs = RT::ObjectCustomFieldValues->new( $self->CurrentUser );
2340     $ocfs->LimitToObject( $self );
2341     return $ocfs;
2342 }
2343
2344 =head2 LoadCustomFieldByIdentifier IDENTIFER
2345
2346 Find the custom field has id or name IDENTIFIER for this object.
2347
2348 If no valid field is found, returns an empty RT::CustomField object.
2349
2350 =cut
2351
2352 sub LoadCustomFieldByIdentifier {
2353     my $self = shift;
2354     my $field = shift;
2355
2356     my $cf;
2357     if ( UNIVERSAL::isa( $field, "RT::CustomField" ) ) {
2358         $cf = RT::CustomField->new($self->CurrentUser);
2359         $cf->SetContextObject( $self );
2360         $cf->LoadById( $field->id );
2361     }
2362     elsif ($field =~ /^\d+$/) {
2363         $cf = RT::CustomField->new($self->CurrentUser);
2364         $cf->SetContextObject( $self );
2365         $cf->LoadById($field);
2366     } else {
2367
2368         my $cfs = $self->CustomFields($self->CurrentUser);
2369         $cfs->SetContextObject( $self );
2370         $cfs->Limit(FIELD => 'Name', VALUE => $field, CASESENSITIVE => 0);
2371         $cf = $cfs->First || RT::CustomField->new($self->CurrentUser);
2372     }
2373     return $cf;
2374 }
2375
2376 sub ACLEquivalenceObjects { }
2377
2378 =head2 HasRight
2379
2380  Takes a paramhash with the attributes 'Right' and 'Principal'
2381   'Right' is a ticket-scoped textual right from RT::ACE
2382   'Principal' is an RT::User object
2383
2384   Returns 1 if the principal has the right. Returns undef if not.
2385
2386 =cut
2387
2388 sub HasRight {
2389     my $self = shift;
2390     my %args = (
2391         Right     => undef,
2392         Principal => undef,
2393         @_
2394     );
2395
2396     $args{Principal} ||= $self->CurrentUser->PrincipalObj;
2397
2398     return $args{'Principal'}->HasRight(
2399         Object => $self->Id ? $self : $RT::System,
2400         Right  => $args{'Right'}
2401     );
2402 }
2403
2404 sub CurrentUserHasRight {
2405     my $self = shift;
2406     return $self->HasRight( Right => @_ );
2407 }
2408
2409 sub ModifyLinkRight { }
2410
2411 =head2 ColumnMapClassName
2412
2413 ColumnMap needs a massaged collection class name to load the correct list
2414 display.  Equivalent to L<RT::SearchBuilder/ColumnMapClassName>, but provided
2415 for a record instead of a collection.
2416
2417 Returns a string.  May be called as a package method.
2418
2419 =cut
2420
2421 sub ColumnMapClassName {
2422     my $self  = shift;
2423     my $Class = ref($self) || $self;
2424        $Class =~ s/:/_/g;
2425     return $Class;
2426 }
2427
2428 sub BasicColumns { }
2429
2430 sub WikiBase {
2431     return RT->Config->Get('WebPath'). "/index.html?q=";
2432 }
2433
2434 sub UID {
2435     my $self = shift;
2436     return undef unless defined $self->Id;
2437     return "@{[ref $self]}-$RT::Organization-@{[$self->Id]}";
2438 }
2439
2440 sub FindDependencies {
2441     my $self = shift;
2442     my ($walker, $deps) = @_;
2443     for my $col (qw/Creator LastUpdatedBy/) {
2444         if ( $self->_Accessible( $col, 'read' ) ) {
2445             next unless $self->$col;
2446             my $obj = RT::Principal->new( $self->CurrentUser );
2447             $obj->Load( $self->$col );
2448             $deps->Add( out => $obj->Object );
2449         }
2450     }
2451
2452     # Object attributes, we have to check on every object
2453     my $objs = $self->Attributes;
2454     $deps->Add( in => $objs );
2455
2456     # Transactions
2457     if (   $self->isa("RT::Ticket")
2458         or $self->isa("RT::User")
2459         or $self->isa("RT::Group")
2460         or $self->isa("RT::Article")
2461         or $self->isa("RT::Queue") )
2462     {
2463         $objs = RT::Transactions->new( $self->CurrentUser );
2464         $objs->Limit( FIELD => 'ObjectType', VALUE => ref $self );
2465         $objs->Limit( FIELD => 'ObjectId', VALUE => $self->id );
2466         $deps->Add( in => $objs );
2467     }
2468
2469     # Object custom field values
2470     if ((   $self->isa("RT::Transaction")
2471          or $self->isa("RT::Ticket")
2472          or $self->isa("RT::User")
2473          or $self->isa("RT::Group")
2474          or $self->isa("RT::Queue")
2475          or $self->isa("RT::Article") )
2476             and $self->can("CustomFieldValues") )
2477     {
2478         $objs = $self->CustomFieldValues; # Actually OCFVs
2479         $objs->{find_expired_rows} = 1;
2480         $deps->Add( in => $objs );
2481     }
2482
2483     # ACE records
2484     if (   $self->isa("RT::Group")
2485         or $self->isa("RT::Class")
2486         or $self->isa("RT::Queue")
2487         or $self->isa("RT::CustomField") )
2488     {
2489         $objs = RT::ACL->new( $self->CurrentUser );
2490         $objs->LimitToObject( $self );
2491         $deps->Add( in => $objs );
2492     }
2493 }
2494
2495 sub Serialize {
2496     my $self = shift;
2497     my %args = (
2498         Methods => {},
2499         UIDs    => 1,
2500         @_,
2501     );
2502     my %methods = (
2503         Creator       => "CreatorObj",
2504         LastUpdatedBy => "LastUpdatedByObj",
2505         %{ $args{Methods} || {} },
2506     );
2507
2508     my %values = %{$self->{values}};
2509
2510     my %ca = %{ $self->_ClassAccessible };
2511     my @cols = grep {exists $values{lc $_} and defined $values{lc $_}} keys %ca;
2512
2513     my %store;
2514     $store{$_} = $values{lc $_} for @cols;
2515     $store{id} = $values{id}; # Explicitly necessary in some cases
2516
2517     # Un-apply the _transfer_ encoding, but don't mess with the octets
2518     # themselves.  Calling ->Content directly would, in some cases,
2519     # decode from some mostly-unknown character set -- which reversing
2520     # on the far end would be complicated.
2521     if ($ca{ContentEncoding} and $ca{ContentType}) {
2522         my ($content_col) = grep {exists $ca{$_}} qw/LargeContent Content/;
2523         $store{$content_col} = $self->_DecodeLOB(
2524             "application/octet-stream", # Lie so that we get bytes, not characters
2525             $self->ContentEncoding,
2526             $self->_Value( $content_col, decode_utf8 => 0 )
2527         );
2528         delete $store{ContentEncoding};
2529     }
2530     return %store unless $args{UIDs};
2531
2532     # Use FooObj to turn Foo into a reference to the UID
2533     for my $col ( grep {$store{$_}} @cols ) {
2534         my $method = $methods{$col};
2535         if (not $method) {
2536             $method = $col;
2537             $method =~ s/(Id)?$/Obj/;
2538         }
2539         next unless $self->can($method);
2540
2541         my $obj = $self->$method;
2542         next unless $obj and $obj->isa("RT::Record");
2543         $store{$col} = \($obj->UID);
2544     }
2545
2546     # Anything on an object should get the UID stored instead
2547     if ($store{ObjectType} and $store{ObjectId} and $self->can("Object")) {
2548         delete $store{$_} for qw/ObjectType ObjectId/;
2549         $store{Object} = \($self->Object->UID);
2550     }
2551
2552     return %store;
2553 }
2554
2555 sub PreInflate {
2556     my $class = shift;
2557     my ($importer, $uid, $data) = @_;
2558
2559     my $ca = $class->_ClassAccessible;
2560     my %ca = %{ $ca };
2561
2562     if ($ca{ContentEncoding} and $ca{ContentType}) {
2563         my ($content_col) = grep {exists $ca{$_}} qw/LargeContent Content/;
2564         if (defined $data->{$content_col}) {
2565             my ($ContentEncoding, $Content) = $class->_EncodeLOB(
2566                 $data->{$content_col}, $data->{ContentType},
2567             );
2568             $data->{ContentEncoding} = $ContentEncoding;
2569             $data->{$content_col} = $Content;
2570         }
2571     }
2572
2573     if ($data->{Object} and not $ca{Object}) {
2574         my $ref_uid = ${ delete $data->{Object} };
2575         my $ref = $importer->Lookup( $ref_uid );
2576         if ($ref) {
2577             my ($class, $id) = @{$ref};
2578             $data->{ObjectId} = $id;
2579             $data->{ObjectType} = $class;
2580         } else {
2581             $data->{ObjectId} = 0;
2582             $data->{ObjectType} = "";
2583             $importer->Postpone(
2584                 for => $ref_uid,
2585                 uid => $uid,
2586                 column => "ObjectId",
2587                 classcolumn => "ObjectType",
2588             );
2589         }
2590     }
2591
2592     for my $col (keys %{$data}) {
2593         if (ref $data->{$col}) {
2594             my $ref_uid = ${ $data->{$col} };
2595             my $ref = $importer->Lookup( $ref_uid );
2596             if ($ref) {
2597                 my (undef, $id) = @{$ref};
2598                 $data->{$col} = $id;
2599             } else {
2600                 $data->{$col} = 0;
2601                 $importer->Postpone(
2602                     for => $ref_uid,
2603                     uid => $uid,
2604                     column => $col,
2605                 );
2606             }
2607         }
2608     }
2609
2610     return 1;
2611 }
2612
2613 sub PostInflate {
2614 }
2615
2616 =head2 _AsInsertQuery
2617
2618 Returns INSERT query string that duplicates current record and
2619 can be used to insert record back into DB after delete.
2620
2621 =cut
2622
2623 sub _AsInsertQuery
2624 {
2625     my $self = shift;
2626
2627     my $dbh = $RT::Handle->dbh;
2628
2629     my $res = "INSERT INTO ". $dbh->quote_identifier( $self->Table );
2630     my $values = $self->{'values'};
2631     $res .= "(". join( ",", map { $dbh->quote_identifier( $_ ) } sort keys %$values ) .")";
2632     $res .= " VALUES";
2633     $res .= "(". join( ",", map { $dbh->quote( $values->{$_} ) } sort keys %$values ) .")";
2634     $res .= ";";
2635
2636     return $res;
2637 }
2638
2639 sub BeforeWipeout { return 1 }
2640
2641 =head2 Dependencies
2642
2643 Returns L<RT::Shredder::Dependencies> object.
2644
2645 =cut
2646
2647 sub Dependencies
2648 {
2649     my $self = shift;
2650     my %args = (
2651             Shredder => undef,
2652             Flags => RT::Shredder::Constants::DEPENDS_ON,
2653             @_,
2654            );
2655
2656     unless( $self->id ) {
2657         RT::Shredder::Exception->throw('Object is not loaded');
2658     }
2659
2660     my $deps = RT::Shredder::Dependencies->new();
2661     if( $args{'Flags'} & RT::Shredder::Constants::DEPENDS_ON ) {
2662         $self->__DependsOn( %args, Dependencies => $deps );
2663     }
2664     return $deps;
2665 }
2666
2667 sub __DependsOn
2668 {
2669     my $self = shift;
2670     my %args = (
2671             Shredder => undef,
2672             Dependencies => undef,
2673             @_,
2674            );
2675     my $deps = $args{'Dependencies'};
2676     my $list = [];
2677
2678 # Object custom field values
2679     my $objs = $self->CustomFieldValues;
2680     $objs->{'find_expired_rows'} = 1;
2681     push( @$list, $objs );
2682
2683 # Object attributes
2684     $objs = $self->Attributes;
2685     push( @$list, $objs );
2686
2687 # Transactions
2688     $objs = RT::Transactions->new( $self->CurrentUser );
2689     $objs->Limit( FIELD => 'ObjectType', VALUE => ref $self );
2690     $objs->Limit( FIELD => 'ObjectId', VALUE => $self->id );
2691     push( @$list, $objs );
2692
2693 # Links
2694     if ( $self->can('Links') ) {
2695         # make sure we don't skip any record
2696         no warnings 'redefine';
2697         local *RT::Links::IsValidLink = sub { 1 };
2698
2699         foreach ( qw(Base Target) ) {
2700             my $objs = $self->Links( $_ );
2701             $objs->_DoSearch;
2702             push @$list, $objs->ItemsArrayRef;
2703         }
2704     }
2705
2706 # ACE records
2707     $objs = RT::ACL->new( $self->CurrentUser );
2708     $objs->LimitToObject( $self );
2709     push( @$list, $objs );
2710
2711     $deps->_PushDependencies(
2712             BaseObject => $self,
2713             Flags => RT::Shredder::Constants::DEPENDS_ON,
2714             TargetObjects => $list,
2715             Shredder => $args{'Shredder'}
2716         );
2717     return;
2718 }
2719
2720 # implement proxy method because some RT classes
2721 # override Delete method
2722 sub __Wipeout
2723 {
2724     my $self = shift;
2725     my $msg = $self->UID ." wiped out";
2726     $self->SUPER::Delete;
2727     $RT::Logger->info( $msg );
2728     return;
2729 }
2730
2731 RT::Base->_ImportOverlays();
2732
2733 1;