Upgrade to 4.0.10.
[usit-rt.git] / lib / RT / Record.pm
1 # BEGIN BPS TAGGED BLOCK {{{
2 #
3 # COPYRIGHT:
4 #
5 # This software is Copyright (c) 1996-2013 Best Practical Solutions, LLC
6 #                                          <sales@bestpractical.com>
7 #
8 # (Except where explicitly superseded by other copyright notices)
9 #
10 #
11 # LICENSE:
12 #
13 # This work is made available to you under the terms of Version 2 of
14 # the GNU General Public License. A copy of that license should have
15 # been provided with this software, but in any event can be snarfed
16 # from www.gnu.org.
17 #
18 # This work is distributed in the hope that it will be useful, but
19 # WITHOUT ANY WARRANTY; without even the implied warranty of
20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
21 # General Public License for more details.
22 #
23 # You should have received a copy of the GNU General Public License
24 # along with this program; if not, write to the Free Software
25 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
26 # 02110-1301 or visit their web page on the internet at
27 # http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
28 #
29 #
30 # CONTRIBUTION SUBMISSION POLICY:
31 #
32 # (The following paragraph is not intended to limit the rights granted
33 # to you to modify and distribute this software under the terms of
34 # the GNU General Public License and is only of importance to you if
35 # you choose to contribute your changes and enhancements to the
36 # community by submitting them to Best Practical Solutions, LLC.)
37 #
38 # By intentionally submitting any modifications, corrections or
39 # derivatives to this work, or any other work intended for use with
40 # Request Tracker, to Best Practical Solutions, LLC, you confirm that
41 # you are the copyright holder for those contributions and you grant
42 # Best Practical Solutions,  LLC a nonexclusive, worldwide, irrevocable,
43 # royalty-free, perpetual, license to use, copy, create derivative
44 # works based on those contributions, and sublicense and distribute
45 # those contributions and any derivatives thereof.
46 #
47 # END BPS TAGGED BLOCK }}}
48
49 =head1 NAME
50
51   RT::Record - Base class for RT record objects
52
53 =head1 SYNOPSIS
54
55
56 =head1 DESCRIPTION
57
58
59
60 =head1 METHODS
61
62 =cut
63
64 package RT::Record;
65
66 use strict;
67 use warnings;
68
69
70 use RT::Date;
71 use RT::User;
72 use RT::Attributes;
73 use Encode qw();
74
75 our $_TABLE_ATTR = { };
76 use base RT->Config->Get('RecordBaseClass');
77 use base 'RT::Base';
78
79
80 sub _Init {
81     my $self = shift;
82     $self->_BuildTableAttributes unless ($_TABLE_ATTR->{ref($self)});
83     $self->CurrentUser(@_);
84 }
85
86
87
88 =head2 _PrimaryKeys
89
90 The primary keys for RT classes is 'id'
91
92 =cut
93
94 sub _PrimaryKeys { return ['id'] }
95 # short circuit many, many thousands of calls from searchbuilder
96 sub _PrimaryKey { 'id' }
97
98 =head2 Id
99
100 Override L<DBIx::SearchBuilder/Id> to avoid a few lookups RT doesn't do
101 on a very common codepath
102
103 C<id> is an alias to C<Id> and is the preferred way to call this method.
104
105 =cut
106
107 sub Id {
108     return shift->{'values'}->{id};
109 }
110
111 *id = \&Id;
112
113 =head2 Delete
114
115 Delete this record object from the database.
116
117 =cut
118
119 sub Delete {
120     my $self = shift;
121     my ($rv) = $self->SUPER::Delete;
122     if ($rv) {
123         return ($rv, $self->loc("Object deleted"));
124     } else {
125
126         return(0, $self->loc("Object could not be deleted"))
127     } 
128 }
129
130 =head2 ObjectTypeStr
131
132 Returns a string which is this object's type.  The type is the class,
133 without the "RT::" prefix.
134
135
136 =cut
137
138 sub ObjectTypeStr {
139     my $self = shift;
140     if (ref($self) =~ /^.*::(\w+)$/) {
141         return $self->loc($1);
142     } else {
143         return $self->loc(ref($self));
144     }
145 }
146
147 =head2 Attributes
148
149 Return this object's attributes as an RT::Attributes object
150
151 =cut
152
153 sub Attributes {
154     my $self = shift;
155     unless ($self->{'attributes'}) {
156         $self->{'attributes'} = RT::Attributes->new($self->CurrentUser);
157         $self->{'attributes'}->LimitToObject($self);
158         $self->{'attributes'}->OrderByCols({FIELD => 'id'});
159     }
160     return ($self->{'attributes'});
161 }
162
163
164 =head2 AddAttribute { Name, Description, Content }
165
166 Adds a new attribute for this object.
167
168 =cut
169
170 sub AddAttribute {
171     my $self = shift;
172     my %args = ( Name        => undef,
173                  Description => undef,
174                  Content     => undef,
175                  @_ );
176
177     my $attr = RT::Attribute->new( $self->CurrentUser );
178     my ( $id, $msg ) = $attr->Create( 
179                                       Object    => $self,
180                                       Name        => $args{'Name'},
181                                       Description => $args{'Description'},
182                                       Content     => $args{'Content'} );
183
184
185     # XXX TODO: Why won't RedoSearch work here?                                     
186     $self->Attributes->_DoSearch;
187     
188     return ($id, $msg);
189 }
190
191
192 =head2 SetAttribute { Name, Description, Content }
193
194 Like AddAttribute, but replaces all existing attributes with the same Name.
195
196 =cut
197
198 sub SetAttribute {
199     my $self = shift;
200     my %args = ( Name        => undef,
201                  Description => undef,
202                  Content     => undef,
203                  @_ );
204
205     my @AttributeObjs = $self->Attributes->Named( $args{'Name'} )
206         or return $self->AddAttribute( %args );
207
208     my $AttributeObj = pop( @AttributeObjs );
209     $_->Delete foreach @AttributeObjs;
210
211     $AttributeObj->SetDescription( $args{'Description'} );
212     $AttributeObj->SetContent( $args{'Content'} );
213
214     $self->Attributes->RedoSearch;
215     return 1;
216 }
217
218 =head2 DeleteAttribute NAME
219
220 Deletes all attributes with the matching name for this object.
221
222 =cut
223
224 sub DeleteAttribute {
225     my $self = shift;
226     my $name = shift;
227     my ($val,$msg) =  $self->Attributes->DeleteEntry( Name => $name );
228     $self->ClearAttributes;
229     return ($val,$msg);
230 }
231
232 =head2 FirstAttribute NAME
233
234 Returns the first attribute with the matching name for this object (as an
235 L<RT::Attribute> object), or C<undef> if no such attributes exist.
236 If there is more than one attribute with the matching name on the
237 object, the first value that was set is returned.
238
239 =cut
240
241 sub FirstAttribute {
242     my $self = shift;
243     my $name = shift;
244     return ($self->Attributes->Named( $name ))[0];
245 }
246
247
248 sub ClearAttributes {
249     my $self = shift;
250     delete $self->{'attributes'};
251
252 }
253
254 sub _Handle { return $RT::Handle }
255
256
257
258 =head2  Create PARAMHASH
259
260 Takes a PARAMHASH of Column -> Value pairs.
261 If any Column has a Validate$PARAMNAME subroutine defined and the 
262 value provided doesn't pass validation, this routine returns
263 an error.
264
265 If this object's table has any of the following atetributes defined as
266 'Auto', this routine will automatically fill in their values.
267
268 =over
269
270 =item Created
271
272 =item Creator
273
274 =item LastUpdated
275
276 =item LastUpdatedBy
277
278 =back
279
280 =cut
281
282 sub Create {
283     my $self    = shift;
284     my %attribs = (@_);
285     foreach my $key ( keys %attribs ) {
286         if (my $method = $self->can("Validate$key")) {
287         if (! $method->( $self, $attribs{$key} ) ) {
288             if (wantarray) {
289                 return ( 0, $self->loc('Invalid value for [_1]', $key) );
290             }
291             else {
292                 return (0);
293             }
294         }
295         }
296     }
297
298
299
300     my ($sec,$min,$hour,$mday,$mon,$year,$wday,$ydaym,$isdst,$offset) = gmtime();
301
302     my $now_iso =
303      sprintf("%04d-%02d-%02d %02d:%02d:%02d", ($year+1900), ($mon+1), $mday, $hour, $min, $sec);
304
305     $attribs{'Created'} = $now_iso if ( $self->_Accessible( 'Created', 'auto' ) && !$attribs{'Created'});
306
307     if ($self->_Accessible( 'Creator', 'auto' ) && !$attribs{'Creator'}) {
308          $attribs{'Creator'} = $self->CurrentUser->id || '0'; 
309     }
310     $attribs{'LastUpdated'} = $now_iso
311       if ( $self->_Accessible( 'LastUpdated', 'auto' ) && !$attribs{'LastUpdated'});
312
313     $attribs{'LastUpdatedBy'} = $self->CurrentUser->id || '0'
314       if ( $self->_Accessible( 'LastUpdatedBy', 'auto' ) && !$attribs{'LastUpdatedBy'});
315
316     my $id = $self->SUPER::Create(%attribs);
317     if ( UNIVERSAL::isa( $id, 'Class::ReturnValue' ) ) {
318         if ( $id->errno ) {
319             if (wantarray) {
320                 return ( 0,
321                     $self->loc( "Internal Error: [_1]", $id->{error_message} ) );
322             }
323             else {
324                 return (0);
325             }
326         }
327     }
328     # If the object was created in the database, 
329     # load it up now, so we're sure we get what the database 
330     # has.  Arguably, this should not be necessary, but there
331     # isn't much we can do about it.
332
333    unless ($id) { 
334     if (wantarray) {
335         return ( $id, $self->loc('Object could not be created') );
336     }
337     else {
338         return ($id);
339     }
340
341    }
342
343     if  (UNIVERSAL::isa('errno',$id)) {
344         return(undef);
345     }
346
347     $self->Load($id) if ($id);
348
349
350
351     if (wantarray) {
352         return ( $id, $self->loc('Object created') );
353     }
354     else {
355         return ($id);
356     }
357
358 }
359
360
361
362 =head2 LoadByCols
363
364 Override DBIx::SearchBuilder::LoadByCols to do case-insensitive loads if the 
365 DB is case sensitive
366
367 =cut
368
369 sub LoadByCols {
370     my $self = shift;
371
372     # We don't want to hang onto this
373     $self->ClearAttributes;
374
375     return $self->SUPER::LoadByCols( @_ ) unless $self->_Handle->CaseSensitive;
376
377     # If this database is case sensitive we need to uncase objects for
378     # explicit loading
379     my %hash = (@_);
380     foreach my $key ( keys %hash ) {
381
382         # If we've been passed an empty value, we can't do the lookup. 
383         # We don't need to explicitly downcase integers or an id.
384         if ( $key ne 'id' && defined $hash{ $key } && $hash{ $key } !~ /^\d+$/ ) {
385             my ($op, $val, $func);
386             ($key, $op, $val, $func) =
387                 $self->_Handle->_MakeClauseCaseInsensitive( $key, '=', delete $hash{ $key } );
388             $hash{$key}->{operator} = $op;
389             $hash{$key}->{value}    = $val;
390             $hash{$key}->{function} = $func;
391         }
392     }
393     return $self->SUPER::LoadByCols( %hash );
394 }
395
396
397
398 # There is room for optimizations in most of those subs:
399
400
401 sub LastUpdatedObj {
402     my $self = shift;
403     my $obj  = RT::Date->new( $self->CurrentUser );
404
405     $obj->Set( Format => 'sql', Value => $self->LastUpdated );
406     return $obj;
407 }
408
409
410
411 sub CreatedObj {
412     my $self = shift;
413     my $obj  = RT::Date->new( $self->CurrentUser );
414
415     $obj->Set( Format => 'sql', Value => $self->Created );
416
417     return $obj;
418 }
419
420
421 #
422 # TODO: This should be deprecated
423 #
424 sub AgeAsString {
425     my $self = shift;
426     return ( $self->CreatedObj->AgeAsString() );
427 }
428
429
430
431 # TODO this should be deprecated
432
433 sub LastUpdatedAsString {
434     my $self = shift;
435     if ( $self->LastUpdated ) {
436         return ( $self->LastUpdatedObj->AsString() );
437
438     }
439     else {
440         return "never";
441     }
442 }
443
444
445 #
446 # TODO This should be deprecated 
447 #
448 sub CreatedAsString {
449     my $self = shift;
450     return ( $self->CreatedObj->AsString() );
451 }
452
453
454 #
455 # TODO This should be deprecated
456 #
457 sub LongSinceUpdateAsString {
458     my $self = shift;
459     if ( $self->LastUpdated ) {
460
461         return ( $self->LastUpdatedObj->AgeAsString() );
462
463     }
464     else {
465         return "never";
466     }
467 }
468
469
470
471 #
472 sub _Set {
473     my $self = shift;
474
475     my %args = (
476         Field => undef,
477         Value => undef,
478         IsSQL => undef,
479         @_
480     );
481
482     #if the user is trying to modify the record
483     # TODO: document _why_ this code is here
484
485     if ( ( !defined( $args{'Field'} ) ) || ( !defined( $args{'Value'} ) ) ) {
486         $args{'Value'} = 0;
487     }
488
489     my $old_val = $self->__Value($args{'Field'});
490      $self->_SetLastUpdated();
491     my $ret = $self->SUPER::_Set(
492         Field => $args{'Field'},
493         Value => $args{'Value'},
494         IsSQL => $args{'IsSQL'}
495     );
496         my ($status, $msg) =  $ret->as_array();
497
498         # @values has two values, a status code and a message.
499
500     # $ret is a Class::ReturnValue object. as such, in a boolean context, it's a bool
501     # we want to change the standard "success" message
502     if ($status) {
503         if ($self->SQLType( $args{'Field'}) =~ /text/) {
504             $msg = $self->loc(
505                 "[_1] updated",
506                 $self->loc( $args{'Field'} ),
507             );
508         } else {
509             $msg = $self->loc(
510                 "[_1] changed from [_2] to [_3]",
511                 $self->loc( $args{'Field'} ),
512                 ( $old_val ? '"' . $old_val . '"' : $self->loc("(no value)") ),
513                 '"' . $self->__Value( $args{'Field'}) . '"',
514             );
515         }
516     } else {
517         $msg = $self->CurrentUser->loc_fuzzy($msg);
518     }
519
520     return wantarray ? ($status, $msg) : $ret;
521 }
522
523
524
525 =head2 _SetLastUpdated
526
527 This routine updates the LastUpdated and LastUpdatedBy columns of the row in question
528 It takes no options. Arguably, this is a bug
529
530 =cut
531
532 sub _SetLastUpdated {
533     my $self = shift;
534     use RT::Date;
535     my $now = RT::Date->new( $self->CurrentUser );
536     $now->SetToNow();
537
538     if ( $self->_Accessible( 'LastUpdated', 'auto' ) ) {
539         my ( $msg, $val ) = $self->__Set(
540             Field => 'LastUpdated',
541             Value => $now->ISO
542         );
543     }
544     if ( $self->_Accessible( 'LastUpdatedBy', 'auto' ) ) {
545         my ( $msg, $val ) = $self->__Set(
546             Field => 'LastUpdatedBy',
547             Value => $self->CurrentUser->id
548         );
549     }
550 }
551
552
553
554 =head2 CreatorObj
555
556 Returns an RT::User object with the RT account of the creator of this row
557
558 =cut
559
560 sub CreatorObj {
561     my $self = shift;
562     unless ( exists $self->{'CreatorObj'} ) {
563
564         $self->{'CreatorObj'} = RT::User->new( $self->CurrentUser );
565         $self->{'CreatorObj'}->Load( $self->Creator );
566     }
567     return ( $self->{'CreatorObj'} );
568 }
569
570
571
572 =head2 LastUpdatedByObj
573
574   Returns an RT::User object of the last user to touch this object
575
576 =cut
577
578 sub LastUpdatedByObj {
579     my $self = shift;
580     unless ( exists $self->{LastUpdatedByObj} ) {
581         $self->{'LastUpdatedByObj'} = RT::User->new( $self->CurrentUser );
582         $self->{'LastUpdatedByObj'}->Load( $self->LastUpdatedBy );
583     }
584     return $self->{'LastUpdatedByObj'};
585 }
586
587
588
589 =head2 URI
590
591 Returns this record's URI
592
593 =cut
594
595 sub URI {
596     my $self = shift;
597     my $uri = RT::URI::fsck_com_rt->new($self->CurrentUser);
598     return($uri->URIForObject($self));
599 }
600
601
602 =head2 ValidateName NAME
603
604 Validate the name of the record we're creating. Mostly, just make sure it's not a numeric ID, which is invalid for Name
605
606 =cut
607
608 sub ValidateName {
609     my $self = shift;
610     my $value = shift;
611     if (defined $value && $value=~ /^\d+$/) {
612         return(0);
613     } else  {
614         return(1);
615     }
616 }
617
618
619
620 =head2 SQLType attribute
621
622 return the SQL type for the attribute 'attribute' as stored in _ClassAccessible
623
624 =cut
625
626 sub SQLType {
627     my $self = shift;
628     my $field = shift;
629
630     return ($self->_Accessible($field, 'type'));
631
632
633 }
634
635 sub __Value {
636     my $self  = shift;
637     my $field = shift;
638     my %args  = ( decode_utf8 => 1, @_ );
639
640     unless ($field) {
641         $RT::Logger->error("__Value called with undef field");
642     }
643
644     my $value = $self->SUPER::__Value($field);
645
646     return undef if (!defined $value);
647
648     if ( $args{'decode_utf8'} ) {
649         if ( !utf8::is_utf8($value) ) {
650             utf8::decode($value);
651         }
652     }
653     else {
654         if ( utf8::is_utf8($value) ) {
655             utf8::encode($value);
656         }
657     }
658
659     return $value;
660
661 }
662
663 # Set up defaults for DBIx::SearchBuilder::Record::Cachable
664
665 sub _CacheConfig {
666   {
667      'cache_p'        => 1,
668      'cache_for_sec'  => 30,
669   }
670 }
671
672
673
674 sub _BuildTableAttributes {
675     my $self = shift;
676     my $class = ref($self) || $self;
677
678     my $attributes;
679     if ( UNIVERSAL::can( $self, '_CoreAccessible' ) ) {
680        $attributes = $self->_CoreAccessible();
681     } elsif ( UNIVERSAL::can( $self, '_ClassAccessible' ) ) {
682        $attributes = $self->_ClassAccessible();
683
684     }
685
686     foreach my $column (keys %$attributes) {
687         foreach my $attr ( keys %{ $attributes->{$column} } ) {
688             $_TABLE_ATTR->{$class}->{$column}->{$attr} = $attributes->{$column}->{$attr};
689         }
690     }
691     foreach my $method ( qw(_OverlayAccessible _VendorAccessible _LocalAccessible) ) {
692         next unless UNIVERSAL::can( $self, $method );
693         $attributes = $self->$method();
694
695         foreach my $column ( keys %$attributes ) {
696             foreach my $attr ( keys %{ $attributes->{$column} } ) {
697                 $_TABLE_ATTR->{$class}->{$column}->{$attr} = $attributes->{$column}->{$attr};
698             }
699         }
700     }
701 }
702
703
704 =head2 _ClassAccessible 
705
706 Overrides the "core" _ClassAccessible using $_TABLE_ATTR. Behaves identical to the version in
707 DBIx::SearchBuilder::Record
708
709 =cut
710
711 sub _ClassAccessible {
712     my $self = shift;
713     return $_TABLE_ATTR->{ref($self) || $self};
714 }
715
716 =head2 _Accessible COLUMN ATTRIBUTE
717
718 returns the value of ATTRIBUTE for COLUMN
719
720
721 =cut 
722
723 sub _Accessible  {
724   my $self = shift;
725   my $column = shift;
726   my $attribute = lc(shift);
727   return 0 unless defined ($_TABLE_ATTR->{ref($self)}->{$column});
728   return $_TABLE_ATTR->{ref($self)}->{$column}->{$attribute} || 0;
729
730 }
731
732 =head2 _EncodeLOB BODY MIME_TYPE
733
734 Takes a potentially large attachment. Returns (ContentEncoding, EncodedBody) based on system configuration and selected database
735
736 =cut
737
738 sub _EncodeLOB {
739         my $self = shift;
740         my $Body = shift;
741         my $MIMEType = shift || '';
742         my $Filename = shift;
743
744         my $ContentEncoding = 'none';
745
746         #get the max attachment length from RT
747         my $MaxSize = RT->Config->Get('MaxAttachmentSize');
748
749         #if the current attachment contains nulls and the
750         #database doesn't support embedded nulls
751
752         if ( ( !$RT::Handle->BinarySafeBLOBs ) && ( $Body =~ /\x00/ ) ) {
753
754             # set a flag telling us to mimencode the attachment
755             $ContentEncoding = 'base64';
756
757             #cut the max attchment size by 25% (for mime-encoding overhead.
758             $RT::Logger->debug("Max size is $MaxSize");
759             $MaxSize = $MaxSize * 3 / 4;
760         # Some databases (postgres) can't handle non-utf8 data
761         } elsif (    !$RT::Handle->BinarySafeBLOBs
762                   && $MIMEType !~ /text\/plain/gi
763                   && !Encode::is_utf8( $Body, 1 ) ) {
764               $ContentEncoding = 'quoted-printable';
765         }
766
767         #if the attachment is larger than the maximum size
768         if ( ($MaxSize) and ( $MaxSize < length($Body) ) ) {
769
770             # if we're supposed to truncate large attachments
771             if (RT->Config->Get('TruncateLongAttachments')) {
772
773                 # truncate the attachment to that length.
774                 $Body = substr( $Body, 0, $MaxSize );
775
776             }
777
778             # elsif we're supposed to drop large attachments on the floor,
779             elsif (RT->Config->Get('DropLongAttachments')) {
780
781                 # drop the attachment on the floor
782                 $RT::Logger->info( "$self: Dropped an attachment of size "
783                                    . length($Body));
784                 $RT::Logger->info( "It started: " . substr( $Body, 0, 60 ) );
785                 $Filename .= ".txt" if $Filename;
786                 return ("none", "Large attachment dropped", "plain/text", $Filename );
787             }
788         }
789
790         # if we need to mimencode the attachment
791         if ( $ContentEncoding eq 'base64' ) {
792
793             # base64 encode the attachment
794             Encode::_utf8_off($Body);
795             $Body = MIME::Base64::encode_base64($Body);
796
797         } elsif ($ContentEncoding eq 'quoted-printable') {
798             Encode::_utf8_off($Body);
799             $Body = MIME::QuotedPrint::encode($Body);
800         }
801
802
803         return ($ContentEncoding, $Body, $MIMEType, $Filename );
804
805 }
806
807 sub _DecodeLOB {
808     my $self            = shift;
809     my $ContentType     = shift || '';
810     my $ContentEncoding = shift || 'none';
811     my $Content         = shift;
812
813     if ( $ContentEncoding eq 'base64' ) {
814         $Content = MIME::Base64::decode_base64($Content);
815     }
816     elsif ( $ContentEncoding eq 'quoted-printable' ) {
817         $Content = MIME::QuotedPrint::decode($Content);
818     }
819     elsif ( $ContentEncoding && $ContentEncoding ne 'none' ) {
820         return ( $self->loc( "Unknown ContentEncoding [_1]", $ContentEncoding ) );
821     }
822     if ( RT::I18N::IsTextualContentType($ContentType) ) {
823        $Content = Encode::decode_utf8($Content) unless Encode::is_utf8($Content);
824     }
825         return ($Content);
826 }
827
828 # A helper table for links mapping to make it easier
829 # to build and parse links between tickets
830
831 use vars '%LINKDIRMAP';
832
833 %LINKDIRMAP = (
834     MemberOf => { Base => 'MemberOf',
835                   Target => 'HasMember', },
836     RefersTo => { Base => 'RefersTo',
837                 Target => 'ReferredToBy', },
838     DependsOn => { Base => 'DependsOn',
839                    Target => 'DependedOnBy', },
840     MergedInto => { Base => 'MergedInto',
841                    Target => 'MergedInto', },
842
843 );
844
845 =head2 Update  ARGSHASH
846
847 Updates fields on an object for you using the proper Set methods,
848 skipping unchanged values.
849
850  ARGSRef => a hashref of attributes => value for the update
851  AttributesRef => an arrayref of keys in ARGSRef that should be updated
852  AttributePrefix => a prefix that should be added to the attributes in AttributesRef
853                     when looking up values in ARGSRef
854                     Bare attributes are tried before prefixed attributes
855
856 Returns a list of localized results of the update
857
858 =cut
859
860 sub Update {
861     my $self = shift;
862
863     my %args = (
864         ARGSRef         => undef,
865         AttributesRef   => undef,
866         AttributePrefix => undef,
867         @_
868     );
869
870     my $attributes = $args{'AttributesRef'};
871     my $ARGSRef    = $args{'ARGSRef'};
872     my %new_values;
873
874     # gather all new values
875     foreach my $attribute (@$attributes) {
876         my $value;
877         if ( defined $ARGSRef->{$attribute} ) {
878             $value = $ARGSRef->{$attribute};
879         }
880         elsif (
881             defined( $args{'AttributePrefix'} )
882             && defined(
883                 $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute }
884             )
885           ) {
886             $value = $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute };
887
888         }
889         else {
890             next;
891         }
892
893         $value =~ s/\r\n/\n/gs;
894
895         # If Queue is 'General', we want to resolve the queue name for
896         # the object.
897
898         # This is in an eval block because $object might not exist.
899         # and might not have a Name method. But "can" won't find autoloaded
900         # items. If it fails, we don't care
901         do {
902             no warnings "uninitialized";
903             local $@;
904             eval {
905                 my $object = $attribute . "Obj";
906                 my $name = $self->$object->Name;
907                 next if $name eq $value || $name eq ($value || 0);
908             };
909
910             my $current = $self->$attribute();
911             # RT::Queue->Lifecycle returns a Lifecycle object instead of name
912             $current = eval { $current->Name } if ref $current;
913             next if $value eq $current;
914             next if ( $value || 0 ) eq $current;
915         };
916
917         $new_values{$attribute} = $value;
918     }
919
920     return $self->_UpdateAttributes(
921         Attributes => $attributes,
922         NewValues  => \%new_values,
923     );
924 }
925
926 sub _UpdateAttributes {
927     my $self = shift;
928     my %args = (
929         Attributes => [],
930         NewValues  => {},
931         @_,
932     );
933
934     my @results;
935
936     foreach my $attribute (@{ $args{Attributes} }) {
937         next if !exists($args{NewValues}{$attribute});
938
939         my $value = $args{NewValues}{$attribute};
940         my $method = "Set$attribute";
941         my ( $code, $msg ) = $self->$method($value);
942         my ($prefix) = ref($self) =~ /RT(?:.*)::(\w+)/;
943
944         # Default to $id, but use name if we can get it.
945         my $label = $self->id;
946         $label = $self->Name if (UNIVERSAL::can($self,'Name'));
947         # this requires model names to be loc'ed.
948
949 =for loc
950
951     "Ticket" # loc
952     "User" # loc
953     "Group" # loc
954     "Queue" # loc
955
956 =cut
957
958         push @results, $self->loc( $prefix ) . " $label: ". $msg;
959
960 =for loc
961
962                                    "[_1] could not be set to [_2].",       # loc
963                                    "That is already the current value",    # loc
964                                    "No value sent to _Set!",               # loc
965                                    "Illegal value for [_1]",               # loc
966                                    "The new value has been set.",          # loc
967                                    "No column specified",                  # loc
968                                    "Immutable field",                      # loc
969                                    "Nonexistant field?",                   # loc
970                                    "Invalid data",                         # loc
971                                    "Couldn't find row",                    # loc
972                                    "Missing a primary key?: [_1]",         # loc
973                                    "Found Object",                         # loc
974
975 =cut
976
977     }
978
979     return @results;
980 }
981
982
983
984
985 =head2 Members
986
987   This returns an RT::Links object which references all the tickets 
988 which are 'MembersOf' this ticket
989
990 =cut
991
992 sub Members {
993     my $self = shift;
994     return ( $self->_Links( 'Target', 'MemberOf' ) );
995 }
996
997
998
999 =head2 MemberOf
1000
1001   This returns an RT::Links object which references all the tickets that this
1002 ticket is a 'MemberOf'
1003
1004 =cut
1005
1006 sub MemberOf {
1007     my $self = shift;
1008     return ( $self->_Links( 'Base', 'MemberOf' ) );
1009 }
1010
1011
1012
1013 =head2 RefersTo
1014
1015   This returns an RT::Links object which shows all references for which this ticket is a base
1016
1017 =cut
1018
1019 sub RefersTo {
1020     my $self = shift;
1021     return ( $self->_Links( 'Base', 'RefersTo' ) );
1022 }
1023
1024
1025
1026 =head2 ReferredToBy
1027
1028 This returns an L<RT::Links> object which shows all references for which this ticket is a target
1029
1030 =cut
1031
1032 sub ReferredToBy {
1033     my $self = shift;
1034     return ( $self->_Links( 'Target', 'RefersTo' ) );
1035 }
1036
1037
1038
1039 =head2 DependedOnBy
1040
1041   This returns an RT::Links object which references all the tickets that depend on this one
1042
1043 =cut
1044
1045 sub DependedOnBy {
1046     my $self = shift;
1047     return ( $self->_Links( 'Target', 'DependsOn' ) );
1048 }
1049
1050
1051
1052
1053 =head2 HasUnresolvedDependencies
1054
1055 Takes a paramhash of Type (default to '__any').  Returns the number of
1056 unresolved dependencies, if $self->UnresolvedDependencies returns an
1057 object with one or more members of that type.  Returns false
1058 otherwise.
1059
1060 =cut
1061
1062 sub HasUnresolvedDependencies {
1063     my $self = shift;
1064     my %args = (
1065         Type   => undef,
1066         @_
1067     );
1068
1069     my $deps = $self->UnresolvedDependencies;
1070
1071     if ($args{Type}) {
1072         $deps->Limit( FIELD => 'Type', 
1073               OPERATOR => '=',
1074               VALUE => $args{Type}); 
1075     }
1076     else {
1077             $deps->IgnoreType;
1078     }
1079
1080     if ($deps->Count > 0) {
1081         return $deps->Count;
1082     }
1083     else {
1084         return (undef);
1085     }
1086 }
1087
1088
1089
1090 =head2 UnresolvedDependencies
1091
1092 Returns an RT::Tickets object of tickets which this ticket depends on
1093 and which have a status of new, open or stalled. (That list comes from
1094 RT::Queue->ActiveStatusArray
1095
1096 =cut
1097
1098
1099 sub UnresolvedDependencies {
1100     my $self = shift;
1101     my $deps = RT::Tickets->new($self->CurrentUser);
1102
1103     my @live_statuses = RT::Queue->ActiveStatusArray();
1104     foreach my $status (@live_statuses) {
1105         $deps->LimitStatus(VALUE => $status);
1106     }
1107     $deps->LimitDependedOnBy($self->Id);
1108
1109     return($deps);
1110
1111 }
1112
1113
1114
1115 =head2 AllDependedOnBy
1116
1117 Returns an array of RT::Ticket objects which (directly or indirectly)
1118 depends on this ticket; takes an optional 'Type' argument in the param
1119 hash, which will limit returned tickets to that type, as well as cause
1120 tickets with that type to serve as 'leaf' nodes that stops the recursive
1121 dependency search.
1122
1123 =cut
1124
1125 sub AllDependedOnBy {
1126     my $self = shift;
1127     return $self->_AllLinkedTickets( LinkType => 'DependsOn',
1128                                      Direction => 'Target', @_ );
1129 }
1130
1131 =head2 AllDependsOn
1132
1133 Returns an array of RT::Ticket objects which this ticket (directly or
1134 indirectly) depends on; takes an optional 'Type' argument in the param
1135 hash, which will limit returned tickets to that type, as well as cause
1136 tickets with that type to serve as 'leaf' nodes that stops the
1137 recursive dependency search.
1138
1139 =cut
1140
1141 sub AllDependsOn {
1142     my $self = shift;
1143     return $self->_AllLinkedTickets( LinkType => 'DependsOn',
1144                                      Direction => 'Base', @_ );
1145 }
1146
1147 sub _AllLinkedTickets {
1148     my $self = shift;
1149
1150     my %args = (
1151         LinkType  => undef,
1152         Direction => undef,
1153         Type   => undef,
1154         _found => {},
1155         _top   => 1,
1156         @_
1157     );
1158
1159     my $dep = $self->_Links( $args{Direction}, $args{LinkType});
1160     while (my $link = $dep->Next()) {
1161         my $uri = $args{Direction} eq 'Target' ? $link->BaseURI : $link->TargetURI;
1162         next unless ($uri->IsLocal());
1163         my $obj = $args{Direction} eq 'Target' ? $link->BaseObj : $link->TargetObj;
1164         next if $args{_found}{$obj->Id};
1165
1166         if (!$args{Type}) {
1167             $args{_found}{$obj->Id} = $obj;
1168             $obj->_AllLinkedTickets( %args, _top => 0 );
1169         }
1170         elsif ($obj->Type and $obj->Type eq $args{Type}) {
1171             $args{_found}{$obj->Id} = $obj;
1172         }
1173         else {
1174             $obj->_AllLinkedTickets( %args, _top => 0 );
1175         }
1176     }
1177
1178     if ($args{_top}) {
1179         return map { $args{_found}{$_} } sort keys %{$args{_found}};
1180     }
1181     else {
1182         return 1;
1183     }
1184 }
1185
1186
1187
1188 =head2 DependsOn
1189
1190   This returns an RT::Links object which references all the tickets that this ticket depends on
1191
1192 =cut
1193
1194 sub DependsOn {
1195     my $self = shift;
1196     return ( $self->_Links( 'Base', 'DependsOn' ) );
1197 }
1198
1199
1200
1201
1202
1203
1204 =head2 Links DIRECTION [TYPE]
1205
1206 Return links (L<RT::Links>) to/from this object.
1207
1208 DIRECTION is either 'Base' or 'Target'.
1209
1210 TYPE is a type of links to return, it can be omitted to get
1211 links of any type.
1212
1213 =cut
1214
1215 sub Links { shift->_Links(@_) }
1216
1217 sub _Links {
1218     my $self = shift;
1219
1220     #TODO: Field isn't the right thing here. but I ahave no idea what mnemonic ---
1221     #tobias meant by $f
1222     my $field = shift;
1223     my $type  = shift || "";
1224
1225     unless ( $self->{"$field$type"} ) {
1226         $self->{"$field$type"} = RT::Links->new( $self->CurrentUser );
1227             # at least to myself
1228             $self->{"$field$type"}->Limit( FIELD => $field,
1229                                            VALUE => $self->URI,
1230                                            ENTRYAGGREGATOR => 'OR' );
1231             $self->{"$field$type"}->Limit( FIELD => 'Type',
1232                                            VALUE => $type )
1233               if ($type);
1234     }
1235     return ( $self->{"$field$type"} );
1236 }
1237
1238
1239
1240
1241 =head2 FormatType
1242
1243 Takes a Type and returns a string that is more human readable.
1244
1245 =cut
1246
1247 sub FormatType{
1248     my $self = shift;
1249     my %args = ( Type => '',
1250                  @_
1251                );
1252     $args{Type} =~ s/([A-Z])/" " . lc $1/ge;
1253     $args{Type} =~ s/^\s+//;
1254     return $args{Type};
1255 }
1256
1257
1258
1259
1260 =head2 FormatLink
1261
1262 Takes either a Target or a Base and returns a string of human friendly text.
1263
1264 =cut
1265
1266 sub FormatLink {
1267     my $self = shift;
1268     my %args = ( Object => undef,
1269                  FallBack => '',
1270                  @_
1271                );
1272     my $text = "URI " . $args{FallBack};
1273     if ($args{Object} && $args{Object}->isa("RT::Ticket")) {
1274         $text = "Ticket " . $args{Object}->id;
1275     }
1276     return $text;
1277 }
1278
1279
1280
1281 =head2 _AddLink
1282
1283 Takes a paramhash of Type and one of Base or Target. Adds that link to this object.
1284
1285 Returns C<link id>, C<message> and C<exist> flag.
1286
1287
1288 =cut
1289
1290 sub _AddLink {
1291     my $self = shift;
1292     my %args = ( Target => '',
1293                  Base   => '',
1294                  Type   => '',
1295                  Silent => undef,
1296                  @_ );
1297
1298
1299     # Remote_link is the URI of the object that is not this ticket
1300     my $remote_link;
1301     my $direction;
1302
1303     if ( $args{'Base'} and $args{'Target'} ) {
1304         $RT::Logger->debug( "$self tried to create a link. both base and target were specified" );
1305         return ( 0, $self->loc("Can't specifiy both base and target") );
1306     }
1307     elsif ( $args{'Base'} ) {
1308         $args{'Target'} = $self->URI();
1309         $remote_link    = $args{'Base'};
1310         $direction      = 'Target';
1311     }
1312     elsif ( $args{'Target'} ) {
1313         $args{'Base'} = $self->URI();
1314         $remote_link  = $args{'Target'};
1315         $direction    = 'Base';
1316     }
1317     else {
1318         return ( 0, $self->loc('Either base or target must be specified') );
1319     }
1320
1321     # Check if the link already exists - we don't want duplicates
1322     use RT::Link;
1323     my $old_link = RT::Link->new( $self->CurrentUser );
1324     $old_link->LoadByParams( Base   => $args{'Base'},
1325                              Type   => $args{'Type'},
1326                              Target => $args{'Target'} );
1327     if ( $old_link->Id ) {
1328         $RT::Logger->debug("$self Somebody tried to duplicate a link");
1329         return ( $old_link->id, $self->loc("Link already exists"), 1 );
1330     }
1331
1332     # }}}
1333
1334
1335     # Storing the link in the DB.
1336     my $link = RT::Link->new( $self->CurrentUser );
1337     my ($linkid, $linkmsg) = $link->Create( Target => $args{Target},
1338                                   Base   => $args{Base},
1339                                   Type   => $args{Type} );
1340
1341     unless ($linkid) {
1342         $RT::Logger->error("Link could not be created: ".$linkmsg);
1343         return ( 0, $self->loc("Link could not be created") );
1344     }
1345
1346     my $basetext = $self->FormatLink(Object => $link->BaseObj,
1347                                      FallBack => $args{Base});
1348     my $targettext = $self->FormatLink(Object => $link->TargetObj,
1349                                        FallBack => $args{Target});
1350     my $typetext = $self->FormatType(Type => $args{Type});
1351     my $TransString =
1352       "$basetext $typetext $targettext.";
1353     return ( $linkid, $TransString ) ;
1354 }
1355
1356
1357
1358 =head2 _DeleteLink
1359
1360 Delete a link. takes a paramhash of Base, Target and Type.
1361 Either Base or Target must be null. The null value will 
1362 be replaced with this ticket's id
1363
1364 =cut 
1365
1366 sub _DeleteLink {
1367     my $self = shift;
1368     my %args = (
1369         Base   => undef,
1370         Target => undef,
1371         Type   => undef,
1372         @_
1373     );
1374
1375     #we want one of base and target. we don't care which
1376     #but we only want _one_
1377
1378     my $direction;
1379     my $remote_link;
1380
1381     if ( $args{'Base'} and $args{'Target'} ) {
1382         $RT::Logger->debug("$self ->_DeleteLink. got both Base and Target");
1383         return ( 0, $self->loc("Can't specifiy 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         $RT::Logger->error("Base or Target must be specified");
1397         return ( 0, $self->loc('Either base or target must be specified') );
1398     }
1399
1400     my $link = RT::Link->new( $self->CurrentUser );
1401     $RT::Logger->debug( "Trying to load link: " . $args{'Base'} . " " . $args{'Type'} . " " . $args{'Target'} );
1402
1403
1404     $link->LoadByParams( Base=> $args{'Base'}, Type=> $args{'Type'}, Target=>  $args{'Target'} );
1405     #it's a real link. 
1406
1407     if ( $link->id ) {
1408         my $basetext = $self->FormatLink(Object => $link->BaseObj,
1409                                      FallBack => $args{Base});
1410         my $targettext = $self->FormatLink(Object => $link->TargetObj,
1411                                        FallBack => $args{Target});
1412         my $typetext = $self->FormatType(Type => $args{Type});
1413         my $linkid = $link->id;
1414         $link->Delete();
1415         my $TransString = "$basetext no longer $typetext $targettext.";
1416         return ( 1, $TransString);
1417     }
1418
1419     #if it's not a link we can find
1420     else {
1421         $RT::Logger->debug("Couldn't find that link");
1422         return ( 0, $self->loc("Link not found") );
1423     }
1424 }
1425
1426
1427 =head1 LockForUpdate
1428
1429 In a database transaction, gains an exclusive lock on the row, to
1430 prevent race conditions.  On SQLite, this is a "RESERVED" lock on the
1431 entire database.
1432
1433 =cut
1434
1435 sub LockForUpdate {
1436     my $self = shift;
1437
1438     my $pk = $self->_PrimaryKey;
1439     my $id = @_ ? $_[0] : $self->$pk;
1440     $self->_expire if $self->isa("DBIx::SearchBuilder::Record::Cachable");
1441     if (RT->Config->Get('DatabaseType') eq "SQLite") {
1442         # SQLite does DB-level locking, upgrading the transaction to
1443         # "RESERVED" on the first UPDATE/INSERT/DELETE.  Do a no-op
1444         # UPDATE to force the upgade.
1445         return RT->DatabaseHandle->dbh->do(
1446             "UPDATE " .$self->Table.
1447                 " SET $pk = $pk WHERE 1 = 0");
1448     } else {
1449         return $self->_LoadFromSQL(
1450             "SELECT * FROM ".$self->Table
1451                 ." WHERE $pk = ? FOR UPDATE",
1452             $id,
1453         );
1454     }
1455 }
1456
1457 =head2 _NewTransaction  PARAMHASH
1458
1459 Private function to create a new RT::Transaction object for this ticket update
1460
1461 =cut
1462
1463 sub _NewTransaction {
1464     my $self = shift;
1465     my %args = (
1466         TimeTaken => undef,
1467         Type      => undef,
1468         OldValue  => undef,
1469         NewValue  => undef,
1470         OldReference  => undef,
1471         NewReference  => undef,
1472         ReferenceType => undef,
1473         Data      => undef,
1474         Field     => undef,
1475         MIMEObj   => undef,
1476         ActivateScrips => 1,
1477         CommitScrips => 1,
1478         SquelchMailTo => undef,
1479         @_
1480     );
1481
1482     my $in_txn = RT->DatabaseHandle->TransactionDepth;
1483     RT->DatabaseHandle->BeginTransaction unless $in_txn;
1484
1485     $self->LockForUpdate;
1486
1487     my $old_ref = $args{'OldReference'};
1488     my $new_ref = $args{'NewReference'};
1489     my $ref_type = $args{'ReferenceType'};
1490     if ($old_ref or $new_ref) {
1491         $ref_type ||= ref($old_ref) || ref($new_ref);
1492         if (!$ref_type) {
1493             $RT::Logger->error("Reference type not specified for transaction");
1494             return;
1495         }
1496         $old_ref = $old_ref->Id if ref($old_ref);
1497         $new_ref = $new_ref->Id if ref($new_ref);
1498     }
1499
1500     require RT::Transaction;
1501     my $trans = RT::Transaction->new( $self->CurrentUser );
1502     my ( $transaction, $msg ) = $trans->Create(
1503         ObjectId  => $self->Id,
1504         ObjectType => ref($self),
1505         TimeTaken => $args{'TimeTaken'},
1506         Type      => $args{'Type'},
1507         Data      => $args{'Data'},
1508         Field     => $args{'Field'},
1509         NewValue  => $args{'NewValue'},
1510         OldValue  => $args{'OldValue'},
1511         NewReference  => $new_ref,
1512         OldReference  => $old_ref,
1513         ReferenceType => $ref_type,
1514         MIMEObj   => $args{'MIMEObj'},
1515         ActivateScrips => $args{'ActivateScrips'},
1516         CommitScrips => $args{'CommitScrips'},
1517         SquelchMailTo => $args{'SquelchMailTo'},
1518     );
1519
1520     # Rationalize the object since we may have done things to it during the caching.
1521     $self->Load($self->Id);
1522
1523     $RT::Logger->warning($msg) unless $transaction;
1524
1525     $self->_SetLastUpdated;
1526
1527     if ( defined $args{'TimeTaken'} and $self->can('_UpdateTimeTaken')) {
1528         $self->_UpdateTimeTaken( $args{'TimeTaken'} );
1529     }
1530     if ( RT->Config->Get('UseTransactionBatch') and $transaction ) {
1531             push @{$self->{_TransactionBatch}}, $trans if $args{'CommitScrips'};
1532     }
1533
1534     RT->DatabaseHandle->Commit unless $in_txn;
1535
1536     return ( $transaction, $msg, $trans );
1537 }
1538
1539
1540
1541 =head2 Transactions
1542
1543   Returns an RT::Transactions object of all transactions on this record object
1544
1545 =cut
1546
1547 sub Transactions {
1548     my $self = shift;
1549
1550     use RT::Transactions;
1551     my $transactions = RT::Transactions->new( $self->CurrentUser );
1552
1553     #If the user has no rights, return an empty object
1554     $transactions->Limit(
1555         FIELD => 'ObjectId',
1556         VALUE => $self->id,
1557     );
1558     $transactions->Limit(
1559         FIELD => 'ObjectType',
1560         VALUE => ref($self),
1561     );
1562
1563     return ($transactions);
1564 }
1565
1566 #
1567
1568 sub CustomFields {
1569     my $self = shift;
1570     my $cfs  = RT::CustomFields->new( $self->CurrentUser );
1571     
1572     $cfs->SetContextObject( $self );
1573     # XXX handle multiple types properly
1574     $cfs->LimitToLookupType( $self->CustomFieldLookupType );
1575     $cfs->LimitToGlobalOrObjectId( $self->CustomFieldLookupId );
1576     $cfs->ApplySortOrder;
1577
1578     return $cfs;
1579 }
1580
1581 # TODO: This _only_ works for RT::Foo classes. it doesn't work, for
1582 # example, for RT::IR::Foo classes.
1583
1584 sub CustomFieldLookupId {
1585     my $self = shift;
1586     my $lookup = shift || $self->CustomFieldLookupType;
1587     my @classes = ($lookup =~ /RT::(\w+)-/g);
1588
1589     # Work on "RT::Queue", for instance
1590     return $self->Id unless @classes;
1591
1592     my $object = $self;
1593     # Save a ->Load call by not calling ->FooObj->Id, just ->Foo
1594     my $final = shift @classes;
1595     foreach my $class (reverse @classes) {
1596         my $method = "${class}Obj";
1597         $object = $object->$method;
1598     }
1599
1600     my $id = $object->$final;
1601     unless (defined $id) {
1602         my $method = "${final}Obj";
1603         $id = $object->$method->Id;
1604     }
1605     return $id;
1606 }
1607
1608
1609 =head2 CustomFieldLookupType 
1610
1611 Returns the path RT uses to figure out which custom fields apply to this object.
1612
1613 =cut
1614
1615 sub CustomFieldLookupType {
1616     my $self = shift;
1617     return ref($self);
1618 }
1619
1620
1621 =head2 AddCustomFieldValue { Field => FIELD, Value => VALUE }
1622
1623 VALUE should be a string. FIELD can be any identifier of a CustomField
1624 supported by L</LoadCustomFieldByIdentifier> method.
1625
1626 Adds VALUE as a value of CustomField FIELD. If this is a single-value custom field,
1627 deletes the old value.
1628 If VALUE is not a valid value for the custom field, returns 
1629 (0, 'Error message' ) otherwise, returns ($id, 'Success Message') where
1630 $id is ID of created L<ObjectCustomFieldValue> object.
1631
1632 =cut
1633
1634 sub AddCustomFieldValue {
1635     my $self = shift;
1636     $self->_AddCustomFieldValue(@_);
1637 }
1638
1639 sub _AddCustomFieldValue {
1640     my $self = shift;
1641     my %args = (
1642         Field             => undef,
1643         Value             => undef,
1644         LargeContent      => undef,
1645         ContentType       => undef,
1646         RecordTransaction => 1,
1647         @_
1648     );
1649
1650     my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
1651     unless ( $cf->Id ) {
1652         return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
1653     }
1654
1655     my $OCFs = $self->CustomFields;
1656     $OCFs->Limit( FIELD => 'id', VALUE => $cf->Id );
1657     unless ( $OCFs->Count ) {
1658         return (
1659             0,
1660             $self->loc(
1661                 "Custom field [_1] does not apply to this object",
1662                 ref $args{'Field'} ? $args{'Field'}->id : $args{'Field'}
1663             )
1664         );
1665     }
1666
1667     # empty string is not correct value of any CF, so undef it
1668     foreach ( qw(Value LargeContent) ) {
1669         $args{ $_ } = undef if defined $args{ $_ } && !length $args{ $_ };
1670     }
1671
1672     unless ( $cf->ValidateValue( $args{'Value'} ) ) {
1673         return ( 0, $self->loc("Invalid value for custom field") );
1674     }
1675
1676     # If the custom field only accepts a certain # of values, delete the existing
1677     # value and record a "changed from foo to bar" transaction
1678     unless ( $cf->UnlimitedValues ) {
1679
1680         # Load up a ObjectCustomFieldValues object for this custom field and this ticket
1681         my $values = $cf->ValuesForObject($self);
1682
1683         # We need to whack any old values here.  In most cases, the custom field should
1684         # only have one value to delete.  In the pathalogical case, this custom field
1685         # used to be a multiple and we have many values to whack....
1686         my $cf_values = $values->Count;
1687
1688         if ( $cf_values > $cf->MaxValues ) {
1689             my $i = 0;   #We want to delete all but the max we can currently have , so we can then
1690                  # execute the same code to "change" the value from old to new
1691             while ( my $value = $values->Next ) {
1692                 $i++;
1693                 if ( $i < $cf_values ) {
1694                     my ( $val, $msg ) = $cf->DeleteValueForObject(
1695                         Object  => $self,
1696                         Content => $value->Content
1697                     );
1698                     unless ($val) {
1699                         return ( 0, $msg );
1700                     }
1701                     my ( $TransactionId, $Msg, $TransactionObj ) =
1702                       $self->_NewTransaction(
1703                         Type         => 'CustomField',
1704                         Field        => $cf->Id,
1705                         OldReference => $value,
1706                       );
1707                 }
1708             }
1709             $values->RedoSearch if $i; # redo search if have deleted at least one value
1710         }
1711
1712         my ( $old_value, $old_content );
1713         if ( $old_value = $values->First ) {
1714             $old_content = $old_value->Content;
1715             $old_content = undef if defined $old_content && !length $old_content;
1716
1717             my $is_the_same = 1;
1718             if ( defined $args{'Value'} ) {
1719                 $is_the_same = 0 unless defined $old_content
1720                     && lc $old_content eq lc $args{'Value'};
1721             } else {
1722                 $is_the_same = 0 if defined $old_content;
1723             }
1724             if ( $is_the_same ) {
1725                 my $old_content = $old_value->LargeContent;
1726                 if ( defined $args{'LargeContent'} ) {
1727                     $is_the_same = 0 unless defined $old_content
1728                         && $old_content eq $args{'LargeContent'};
1729                 } else {
1730                     $is_the_same = 0 if defined $old_content;
1731                 }
1732             }
1733
1734             return $old_value->id if $is_the_same;
1735         }
1736
1737         my ( $new_value_id, $value_msg ) = $cf->AddValueForObject(
1738             Object       => $self,
1739             Content      => $args{'Value'},
1740             LargeContent => $args{'LargeContent'},
1741             ContentType  => $args{'ContentType'},
1742         );
1743
1744         unless ( $new_value_id ) {
1745             return ( 0, $self->loc( "Could not add new custom field value: [_1]", $value_msg ) );
1746         }
1747
1748         my $new_value = RT::ObjectCustomFieldValue->new( $self->CurrentUser );
1749         $new_value->Load( $new_value_id );
1750
1751         # now that adding the new value was successful, delete the old one
1752         if ( $old_value ) {
1753             my ( $val, $msg ) = $old_value->Delete();
1754             return ( 0, $msg ) unless $val;
1755         }
1756
1757         if ( $args{'RecordTransaction'} ) {
1758             my ( $TransactionId, $Msg, $TransactionObj ) =
1759               $self->_NewTransaction(
1760                 Type         => 'CustomField',
1761                 Field        => $cf->Id,
1762                 OldReference => $old_value,
1763                 NewReference => $new_value,
1764               );
1765         }
1766
1767         my $new_content = $new_value->Content;
1768
1769         # For datetime, we need to display them in "human" format in result message
1770         #XXX TODO how about date without time?
1771         if ($cf->Type eq 'DateTime') {
1772             my $DateObj = RT::Date->new( $self->CurrentUser );
1773             $DateObj->Set(
1774                 Format => 'ISO',
1775                 Value  => $new_content,
1776             );
1777             $new_content = $DateObj->AsString;
1778
1779             if ( defined $old_content && length $old_content ) {
1780                 $DateObj->Set(
1781                     Format => 'ISO',
1782                     Value  => $old_content,
1783                 );
1784                 $old_content = $DateObj->AsString;
1785             }
1786         }
1787
1788         unless ( defined $old_content && length $old_content ) {
1789             return ( $new_value_id, $self->loc( "[_1] [_2] added", $cf->Name, $new_content ));
1790         }
1791         elsif ( !defined $new_content || !length $new_content ) {
1792             return ( $new_value_id,
1793                 $self->loc( "[_1] [_2] deleted", $cf->Name, $old_content ) );
1794         }
1795         else {
1796             return ( $new_value_id, $self->loc( "[_1] [_2] changed to [_3]", $cf->Name, $old_content, $new_content));
1797         }
1798
1799     }
1800
1801     # otherwise, just add a new value and record "new value added"
1802     else {
1803         my ($new_value_id, $msg) = $cf->AddValueForObject(
1804             Object       => $self,
1805             Content      => $args{'Value'},
1806             LargeContent => $args{'LargeContent'},
1807             ContentType  => $args{'ContentType'},
1808         );
1809
1810         unless ( $new_value_id ) {
1811             return ( 0, $self->loc( "Could not add new custom field value: [_1]", $msg ) );
1812         }
1813         if ( $args{'RecordTransaction'} ) {
1814             my ( $tid, $msg ) = $self->_NewTransaction(
1815                 Type          => 'CustomField',
1816                 Field         => $cf->Id,
1817                 NewReference  => $new_value_id,
1818                 ReferenceType => 'RT::ObjectCustomFieldValue',
1819             );
1820             unless ( $tid ) {
1821                 return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $msg ) );
1822             }
1823         }
1824         return ( $new_value_id, $self->loc( "[_1] added as a value for [_2]", $args{'Value'}, $cf->Name ) );
1825     }
1826 }
1827
1828
1829
1830 =head2 DeleteCustomFieldValue { Field => FIELD, Value => VALUE }
1831
1832 Deletes VALUE as a value of CustomField FIELD. 
1833
1834 VALUE can be a string, a CustomFieldValue or a ObjectCustomFieldValue.
1835
1836 If VALUE is not a valid value for the custom field, returns 
1837 (0, 'Error message' ) otherwise, returns (1, 'Success Message')
1838
1839 =cut
1840
1841 sub DeleteCustomFieldValue {
1842     my $self = shift;
1843     my %args = (
1844         Field   => undef,
1845         Value   => undef,
1846         ValueId => undef,
1847         @_
1848     );
1849
1850     my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
1851     unless ( $cf->Id ) {
1852         return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
1853     }
1854
1855     my ( $val, $msg ) = $cf->DeleteValueForObject(
1856         Object  => $self,
1857         Id      => $args{'ValueId'},
1858         Content => $args{'Value'},
1859     );
1860     unless ($val) {
1861         return ( 0, $msg );
1862     }
1863
1864     my ( $TransactionId, $Msg, $TransactionObj ) = $self->_NewTransaction(
1865         Type          => 'CustomField',
1866         Field         => $cf->Id,
1867         OldReference  => $val,
1868         ReferenceType => 'RT::ObjectCustomFieldValue',
1869     );
1870     unless ($TransactionId) {
1871         return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $Msg ) );
1872     }
1873
1874     my $old_value = $TransactionObj->OldValue;
1875     # For datetime, we need to display them in "human" format in result message
1876     if ( $cf->Type eq 'DateTime' ) {
1877         my $DateObj = RT::Date->new( $self->CurrentUser );
1878         $DateObj->Set(
1879             Format => 'ISO',
1880             Value  => $old_value,
1881         );
1882         $old_value = $DateObj->AsString;
1883     }
1884     return (
1885         $TransactionId,
1886         $self->loc(
1887             "[_1] is no longer a value for custom field [_2]",
1888             $old_value, $cf->Name
1889         )
1890     );
1891 }
1892
1893
1894
1895 =head2 FirstCustomFieldValue FIELD
1896
1897 Return the content of the first value of CustomField FIELD for this ticket
1898 Takes a field id or name
1899
1900 =cut
1901
1902 sub FirstCustomFieldValue {
1903     my $self = shift;
1904     my $field = shift;
1905
1906     my $values = $self->CustomFieldValues( $field );
1907     return undef unless my $first = $values->First;
1908     return $first->Content;
1909 }
1910
1911 =head2 CustomFieldValuesAsString FIELD
1912
1913 Return the content of the CustomField FIELD for this ticket.
1914 If this is a multi-value custom field, values will be joined with newlines.
1915
1916 Takes a field id or name as the first argument
1917
1918 Takes an optional Separator => "," second and third argument
1919 if you want to join the values using something other than a newline
1920
1921 =cut
1922
1923 sub CustomFieldValuesAsString {
1924     my $self  = shift;
1925     my $field = shift;
1926     my %args  = @_;
1927     my $separator = $args{Separator} || "\n";
1928
1929     my $values = $self->CustomFieldValues( $field );
1930     return join ($separator, grep { defined $_ }
1931                  map { $_->Content } @{$values->ItemsArrayRef});
1932 }
1933
1934
1935
1936 =head2 CustomFieldValues FIELD
1937
1938 Return a ObjectCustomFieldValues object of all values of the CustomField whose 
1939 id or Name is FIELD for this record.
1940
1941 Returns an RT::ObjectCustomFieldValues object
1942
1943 =cut
1944
1945 sub CustomFieldValues {
1946     my $self  = shift;
1947     my $field = shift;
1948
1949     if ( $field ) {
1950         my $cf = $self->LoadCustomFieldByIdentifier( $field );
1951
1952         # we were asked to search on a custom field we couldn't find
1953         unless ( $cf->id ) {
1954             $RT::Logger->warning("Couldn't load custom field by '$field' identifier");
1955             return RT::ObjectCustomFieldValues->new( $self->CurrentUser );
1956         }
1957         return ( $cf->ValuesForObject($self) );
1958     }
1959
1960     # we're not limiting to a specific custom field;
1961     my $ocfs = RT::ObjectCustomFieldValues->new( $self->CurrentUser );
1962     $ocfs->LimitToObject( $self );
1963     return $ocfs;
1964 }
1965
1966 =head2 LoadCustomFieldByIdentifier IDENTIFER
1967
1968 Find the custom field has id or name IDENTIFIER for this object.
1969
1970 If no valid field is found, returns an empty RT::CustomField object.
1971
1972 =cut
1973
1974 sub LoadCustomFieldByIdentifier {
1975     my $self = shift;
1976     my $field = shift;
1977     
1978     my $cf;
1979     if ( UNIVERSAL::isa( $field, "RT::CustomField" ) ) {
1980         $cf = RT::CustomField->new($self->CurrentUser);
1981         $cf->SetContextObject( $self );
1982         $cf->LoadById( $field->id );
1983     }
1984     elsif ($field =~ /^\d+$/) {
1985         $cf = RT::CustomField->new($self->CurrentUser);
1986         $cf->SetContextObject( $self );
1987         $cf->LoadById($field);
1988     } else {
1989
1990         my $cfs = $self->CustomFields($self->CurrentUser);
1991         $cfs->SetContextObject( $self );
1992         $cfs->Limit(FIELD => 'Name', VALUE => $field, CASESENSITIVE => 0);
1993         $cf = $cfs->First || RT::CustomField->new($self->CurrentUser);
1994     }
1995     return $cf;
1996 }
1997
1998 sub ACLEquivalenceObjects { } 
1999
2000 sub BasicColumns { }
2001
2002 sub WikiBase {
2003     return RT->Config->Get('WebPath'). "/index.html?q=";
2004 }
2005
2006 RT::Base->_ImportOverlays();
2007
2008 1;