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