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