1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2017 Best Practical Solutions, LLC
6 # <sales@bestpractical.com>
8 # (Except where explicitly superseded by other copyright notices)
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
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.
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.
30 # CONTRIBUTION SUBMISSION POLICY:
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.)
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.
47 # END BPS TAGGED BLOCK }}}
51 RT::Record - Base class for RT record objects
70 use base RT->Config->Get('RecordBaseClass');
75 require RT::Attributes;
76 require RT::Transactions;
78 use RT::Shredder::Dependencies;
79 use RT::Shredder::Constants;
80 use RT::Shredder::Exceptions;
82 our $_TABLE_ATTR = { };
83 use base RT->Config->Get('RecordBaseClass');
89 $self->_BuildTableAttributes unless ($_TABLE_ATTR->{ref($self)});
90 $self->CurrentUser(@_);
97 The primary keys for RT classes is 'id'
101 sub _PrimaryKeys { return ['id'] }
102 # short circuit many, many thousands of calls from searchbuilder
103 sub _PrimaryKey { 'id' }
107 Override L<DBIx::SearchBuilder/Id> to avoid a few lookups RT doesn't do
108 on a very common codepath
110 C<id> is an alias to C<Id> and is the preferred way to call this method.
115 return shift->{'values'}->{id};
122 Delete this record object from the database.
128 my ($rv) = $self->SUPER::Delete;
130 return ($rv, $self->loc("Object deleted"));
133 return(0, $self->loc("Object could not be deleted"))
139 Returns a string which is this record's type. It's not localized and by
140 default last part (everything after last ::) of class name is returned.
145 my $res = ref($_[0]) || $_[0];
152 DEPRECATED. Stays here for backwards. Returns localized L</RecordType>.
156 # we deprecate because of:
157 # * ObjectType is used in several classes with ObjectId to store
158 # records of different types, for example transactions use those
159 # and it's unclear what this method should return 'Transaction'
160 # or type of referenced record
161 # * returning localized thing is not good idea
167 Instead => "RecordType",
169 return $self->loc( $self->RecordType( @_ ) );
174 Return this object's attributes as an RT::Attributes object
180 unless ($self->{'attributes'}) {
181 $self->{'attributes'} = RT::Attributes->new($self->CurrentUser);
182 $self->{'attributes'}->LimitToObject($self);
183 $self->{'attributes'}->OrderByCols({FIELD => 'id'});
185 return ($self->{'attributes'});
189 =head2 AddAttribute { Name, Description, Content }
191 Adds a new attribute for this object.
197 my %args = ( Name => undef,
198 Description => undef,
202 my $attr = RT::Attribute->new( $self->CurrentUser );
203 my ( $id, $msg ) = $attr->Create(
205 Name => $args{'Name'},
206 Description => $args{'Description'},
207 Content => $args{'Content'} );
210 # XXX TODO: Why won't RedoSearch work here?
211 $self->Attributes->_DoSearch;
217 =head2 SetAttribute { Name, Description, Content }
219 Like AddAttribute, but replaces all existing attributes with the same Name.
225 my %args = ( Name => undef,
226 Description => undef,
230 my @AttributeObjs = $self->Attributes->Named( $args{'Name'} )
231 or return $self->AddAttribute( %args );
233 my $AttributeObj = pop( @AttributeObjs );
234 $_->Delete foreach @AttributeObjs;
236 $AttributeObj->SetDescription( $args{'Description'} );
237 $AttributeObj->SetContent( $args{'Content'} );
239 $self->Attributes->RedoSearch;
243 =head2 DeleteAttribute NAME
245 Deletes all attributes with the matching name for this object.
249 sub DeleteAttribute {
252 my ($val,$msg) = $self->Attributes->DeleteEntry( Name => $name );
253 $self->ClearAttributes;
257 =head2 FirstAttribute NAME
259 Returns the first attribute with the matching name for this object (as an
260 L<RT::Attribute> object), or C<undef> if no such attributes exist.
261 If there is more than one attribute with the matching name on the
262 object, the first value that was set is returned.
269 return ($self->Attributes->Named( $name ))[0];
273 sub ClearAttributes {
275 delete $self->{'attributes'};
279 sub _Handle { return $RT::Handle }
283 =head2 Create PARAMHASH
285 Takes a PARAMHASH of Column -> Value pairs.
286 If any Column has a Validate$PARAMNAME subroutine defined and the
287 value provided doesn't pass validation, this routine returns
290 If this object's table has any of the following atetributes defined as
291 'Auto', this routine will automatically fill in their values.
310 foreach my $key ( keys %attribs ) {
311 if (my $method = $self->can("Validate$key")) {
312 if (! $method->( $self, $attribs{$key} ) ) {
314 return ( 0, $self->loc('Invalid value for [_1]', $key) );
325 my ($sec,$min,$hour,$mday,$mon,$year,$wday,$ydaym,$isdst,$offset) = gmtime();
328 sprintf("%04d-%02d-%02d %02d:%02d:%02d", ($year+1900), ($mon+1), $mday, $hour, $min, $sec);
330 $attribs{'Created'} = $now_iso if ( $self->_Accessible( 'Created', 'auto' ) && !$attribs{'Created'});
332 if ($self->_Accessible( 'Creator', 'auto' ) && !$attribs{'Creator'}) {
333 $attribs{'Creator'} = $self->CurrentUser->id || '0';
335 $attribs{'LastUpdated'} = $now_iso
336 if ( $self->_Accessible( 'LastUpdated', 'auto' ) && !$attribs{'LastUpdated'});
338 $attribs{'LastUpdatedBy'} = $self->CurrentUser->id || '0'
339 if ( $self->_Accessible( 'LastUpdatedBy', 'auto' ) && !$attribs{'LastUpdatedBy'});
341 my $id = $self->SUPER::Create(%attribs);
342 if ( UNIVERSAL::isa( $id, 'Class::ReturnValue' ) ) {
346 $self->loc( "Internal Error: [_1]", $id->{error_message} ) );
353 # If the object was created in the database,
354 # load it up now, so we're sure we get what the database
355 # has. Arguably, this should not be necessary, but there
356 # isn't much we can do about it.
360 return ( $id, $self->loc('Object could not be created') );
368 if (UNIVERSAL::isa('errno',$id)) {
372 $self->Load($id) if ($id);
377 return ( $id, $self->loc('Object created') );
389 Override DBIx::SearchBuilder::LoadByCols to do case-insensitive loads if the
397 # We don't want to hang onto this
398 $self->ClearAttributes;
400 unless ( $self->_Handle->CaseSensitive ) {
401 my ( $ret, $msg ) = $self->SUPER::LoadByCols( @_ );
402 return wantarray ? ( $ret, $msg ) : $ret;
405 # If this database is case sensitive we need to uncase objects for
408 foreach my $key ( keys %hash ) {
410 # If we've been passed an empty value, we can't do the lookup.
411 # We don't need to explicitly downcase integers or an id.
412 if ( $key ne 'id' && defined $hash{ $key } && $hash{ $key } !~ /^\d+$/ ) {
413 my ($op, $val, $func);
414 ($key, $op, $val, $func) =
415 $self->_Handle->_MakeClauseCaseInsensitive( $key, '=', delete $hash{ $key } );
416 $hash{$key}->{operator} = $op;
417 $hash{$key}->{value} = $val;
418 $hash{$key}->{function} = $func;
421 my ( $ret, $msg ) = $self->SUPER::LoadByCols( %hash );
422 return wantarray ? ( $ret, $msg ) : $ret;
427 # There is room for optimizations in most of those subs:
432 my $obj = RT::Date->new( $self->CurrentUser );
434 $obj->Set( Format => 'sql', Value => $self->LastUpdated );
442 my $obj = RT::Date->new( $self->CurrentUser );
444 $obj->Set( Format => 'sql', Value => $self->Created );
450 # B<DEPRECATED> and will be removed in 4.4
455 Instead => "->CreatedObj->AgeAsString",
457 return ( $self->CreatedObj->AgeAsString() );
460 # B<DEPRECATED> and will be removed in 4.4
461 sub LongSinceUpdateAsString {
465 Instead => "->LastUpdatedObj->AgeAsString",
467 if ( $self->LastUpdated ) {
468 return ( $self->LastUpdatedObj->AgeAsString() );
474 sub LastUpdatedAsString {
476 if ( $self->LastUpdated ) {
477 return ( $self->LastUpdatedObj->AsString() );
483 sub CreatedAsString {
485 return ( $self->CreatedObj->AsString() );
498 #if the user is trying to modify the record
499 # TODO: document _why_ this code is here
501 if ( ( !defined( $args{'Field'} ) ) || ( !defined( $args{'Value'} ) ) ) {
505 my $old_val = $self->__Value($args{'Field'});
506 $self->_SetLastUpdated();
507 my $ret = $self->SUPER::_Set(
508 Field => $args{'Field'},
509 Value => $args{'Value'},
510 IsSQL => $args{'IsSQL'}
512 my ($status, $msg) = $ret->as_array();
514 # @values has two values, a status code and a message.
516 # $ret is a Class::ReturnValue object. as such, in a boolean context, it's a bool
517 # we want to change the standard "success" message
519 if ($self->SQLType( $args{'Field'}) =~ /text/) {
522 $self->loc( $args{'Field'} ),
526 "[_1] changed from [_2] to [_3]",
527 $self->loc( $args{'Field'} ),
528 ( $old_val ? '"' . $old_val . '"' : $self->loc("(no value)") ),
529 '"' . $self->__Value( $args{'Field'}) . '"',
533 $msg = $self->CurrentUser->loc_fuzzy($msg);
536 return wantarray ? ($status, $msg) : $ret;
541 =head2 _SetLastUpdated
543 This routine updates the LastUpdated and LastUpdatedBy columns of the row in question
544 It takes no options. Arguably, this is a bug
548 sub _SetLastUpdated {
550 my $now = RT::Date->new( $self->CurrentUser );
553 if ( $self->_Accessible( 'LastUpdated', 'auto' ) ) {
554 my ( $msg, $val ) = $self->__Set(
555 Field => 'LastUpdated',
559 if ( $self->_Accessible( 'LastUpdatedBy', 'auto' ) ) {
560 my ( $msg, $val ) = $self->__Set(
561 Field => 'LastUpdatedBy',
562 Value => $self->CurrentUser->id
571 Returns an RT::User object with the RT account of the creator of this row
577 unless ( exists $self->{'CreatorObj'} ) {
579 $self->{'CreatorObj'} = RT::User->new( $self->CurrentUser );
580 $self->{'CreatorObj'}->Load( $self->Creator );
582 return ( $self->{'CreatorObj'} );
587 =head2 LastUpdatedByObj
589 Returns an RT::User object of the last user to touch this object
593 sub LastUpdatedByObj {
595 unless ( exists $self->{LastUpdatedByObj} ) {
596 $self->{'LastUpdatedByObj'} = RT::User->new( $self->CurrentUser );
597 $self->{'LastUpdatedByObj'}->Load( $self->LastUpdatedBy );
599 return $self->{'LastUpdatedByObj'};
606 Returns this record's URI
612 my $uri = RT::URI::fsck_com_rt->new($self->CurrentUser);
613 return($uri->URIForObject($self));
617 =head2 ValidateName NAME
619 Validate the name of the record we're creating. Mostly, just make sure it's not a numeric ID, which is invalid for Name
626 if (defined $value && $value=~ /^\d+$/) {
635 =head2 SQLType attribute
637 return the SQL type for the attribute 'attribute' as stored in _ClassAccessible
645 return ($self->_Accessible($field, 'type'));
653 my %args = ( decode_utf8 => 1, @_ );
656 $RT::Logger->error("__Value called with undef field");
659 my $value = $self->SUPER::__Value($field);
660 return $value if ref $value;
662 return undef if (!defined $value);
664 # Pg returns character columns as character strings; mysql and
665 # sqlite return them as bytes. While mysql can be made to return
666 # characters, using the mysql_enable_utf8 flag, the "Content" column
667 # is bytes on mysql and characters on Postgres, making true
668 # consistency impossible.
669 if ( $args{'decode_utf8'} ) {
670 if ( !utf8::is_utf8($value) ) { # mysql/sqlite
671 utf8::decode($value);
674 if ( utf8::is_utf8($value) ) {
675 utf8::encode($value);
683 # Set up defaults for DBIx::SearchBuilder::Record::Cachable
687 'cache_for_sec' => 30,
693 sub _BuildTableAttributes {
695 my $class = ref($self) || $self;
698 if ( UNIVERSAL::can( $self, '_CoreAccessible' ) ) {
699 $attributes = $self->_CoreAccessible();
700 } elsif ( UNIVERSAL::can( $self, '_ClassAccessible' ) ) {
701 $attributes = $self->_ClassAccessible();
705 foreach my $column (keys %$attributes) {
706 foreach my $attr ( keys %{ $attributes->{$column} } ) {
707 $_TABLE_ATTR->{$class}->{$column}->{$attr} = $attributes->{$column}->{$attr};
710 foreach my $method ( qw(_OverlayAccessible _VendorAccessible _LocalAccessible) ) {
711 next unless UNIVERSAL::can( $self, $method );
712 $attributes = $self->$method();
714 foreach my $column ( keys %$attributes ) {
715 foreach my $attr ( keys %{ $attributes->{$column} } ) {
716 $_TABLE_ATTR->{$class}->{$column}->{$attr} = $attributes->{$column}->{$attr};
723 =head2 _ClassAccessible
725 Overrides the "core" _ClassAccessible using $_TABLE_ATTR. Behaves identical to the version in
726 DBIx::SearchBuilder::Record
730 sub _ClassAccessible {
732 return $_TABLE_ATTR->{ref($self) || $self};
735 =head2 _Accessible COLUMN ATTRIBUTE
737 returns the value of ATTRIBUTE for COLUMN
745 my $attribute = lc(shift);
747 my $class = ref($self) || $self;
748 $class->_BuildTableAttributes unless ($_TABLE_ATTR->{$class});
750 return 0 unless defined ($_TABLE_ATTR->{$class}->{$column});
751 return $_TABLE_ATTR->{$class}->{$column}->{$attribute} || 0;
755 =head2 _EncodeLOB BODY MIME_TYPE FILENAME
757 Takes a potentially large attachment. Returns (ContentEncoding,
758 EncodedBody, MimeType, Filename, NoteArgs) based on system configuration and
759 selected database. Returns a custom (short) text/plain message if
760 DropLongAttachments causes an attachment to not be stored.
762 Encodes your data as base64 or Quoted-Printable as needed based on your
763 Databases's restrictions and the UTF-8ness of the data being passed in. Since
764 we are storing in columns marked UTF8, we must ensure that binary data is
765 encoded on databases which are strict.
767 This function expects to receive an octet string in order to properly
768 evaluate and encode it. It will return an octet string.
770 NoteArgs is currently used to indicate caller that the message is too long and
771 is truncated or dropped. It's a hashref which is expected to be passed to
772 L<RT::Record/_NewTransaction>.
779 my $MIMEType = shift || '';
780 my $Filename = shift;
782 my $ContentEncoding = 'none';
785 RT::Util::assert_bytes( $Body );
787 #get the max attachment length from RT
788 my $MaxSize = RT->Config->Get('MaxAttachmentSize');
790 #if the current attachment contains nulls and the
791 #database doesn't support embedded nulls
793 if ( ( !$RT::Handle->BinarySafeBLOBs ) && ( $Body =~ /\x00/ ) ) {
795 # set a flag telling us to mimencode the attachment
796 $ContentEncoding = 'base64';
798 #cut the max attchment size by 25% (for mime-encoding overhead.
799 $RT::Logger->debug("Max size is $MaxSize");
800 $MaxSize = $MaxSize * 3 / 4;
801 # Some databases (postgres) can't handle non-utf8 data
802 } elsif ( !$RT::Handle->BinarySafeBLOBs
803 && $Body =~ /\P{ASCII}/
804 && !Encode::is_utf8( $Body, 1 ) ) {
805 $ContentEncoding = 'quoted-printable';
808 #if the attachment is larger than the maximum size
809 if ( ($MaxSize) and ( $MaxSize < length($Body) ) ) {
811 my $size = length $Body;
812 # if we're supposed to truncate large attachments
813 if (RT->Config->Get('TruncateLongAttachments')) {
815 $RT::Logger->info("$self: Truncated an attachment of size $size");
817 # truncate the attachment to that length.
818 $Body = substr( $Body, 0, $MaxSize );
820 Type => 'AttachmentTruncate',
823 NewValue => $MaxSize,
829 # elsif we're supposed to drop large attachments on the floor,
830 elsif (RT->Config->Get('DropLongAttachments')) {
832 # drop the attachment on the floor
833 $RT::Logger->info( "$self: Dropped an attachment of size $size" );
834 $RT::Logger->info( "It started: " . substr( $Body, 0, 60 ) );
836 Type => 'AttachmentDrop',
839 NewValue => $MaxSize,
842 $Filename .= ".txt" if $Filename && $Filename !~ /\.txt$/;
843 return ("none", "Large attachment dropped", "text/plain", $Filename, $note_args );
847 # if we need to mimencode the attachment
848 if ( $ContentEncoding eq 'base64' ) {
849 # base64 encode the attachment
850 $Body = MIME::Base64::encode_base64($Body);
852 } elsif ($ContentEncoding eq 'quoted-printable') {
853 $Body = MIME::QuotedPrint::encode($Body);
857 return ($ContentEncoding, $Body, $MIMEType, $Filename, $note_args );
860 =head2 _DecodeLOB C<ContentType>, C<ContentEncoding>, C<Content>
862 Unpacks data stored in the database, which may be base64 or QP encoded
863 because of our need to store binary and badly encoded data in columns
864 marked as UTF-8. Databases such as PostgreSQL and Oracle care that you
865 are feeding them invalid UTF-8 and will refuse the content. This
866 function handles unpacking the encoded data.
868 It returns textual data as a UTF-8 string which has been processed by Encode's
869 PERLQQ filter which will replace the invalid bytes with \x{HH} so you can see
870 the invalid byte but won't run into problems treating the data as UTF-8 later.
872 This is similar to how we filter all data coming in via the web UI in
873 RT::Interface::Web::DecodeARGS. This filter should only end up being
874 applied to old data from less UTF-8-safe versions of RT.
876 If the passed C<ContentType> includes a character set, that will be used
877 to decode textual data; the default character set is UTF-8. This is
878 necessary because while we attempt to store textual data as UTF-8, the
879 definition of "textual" has migrated over time, and thus we may now need
880 to attempt to decode data that was previously not trancoded on insertion.
882 Important Note - This function expects an octet string and returns a
883 character string for non-binary data.
889 my $ContentType = shift || '';
890 my $ContentEncoding = shift || 'none';
893 RT::Util::assert_bytes( $Content );
895 if ( $ContentEncoding eq 'base64' ) {
896 $Content = MIME::Base64::decode_base64($Content);
898 elsif ( $ContentEncoding eq 'quoted-printable' ) {
899 $Content = MIME::QuotedPrint::decode($Content);
901 elsif ( $ContentEncoding && $ContentEncoding ne 'none' ) {
902 return ( $self->loc( "Unknown ContentEncoding [_1]", $ContentEncoding ) );
904 if ( RT::I18N::IsTextualContentType($ContentType) ) {
905 my $entity = MIME::Entity->new();
906 $entity->head->add("Content-Type", $ContentType);
907 $entity->bodyhandle( MIME::Body::Scalar->new( $Content ) );
908 my $charset = RT::I18N::_FindOrGuessCharset($entity);
909 $charset = 'utf-8' if not $charset or not Encode::find_encoding($charset);
911 $Content = Encode::decode($charset,$Content,Encode::FB_PERLQQ);
916 =head2 Update ARGSHASH
918 Updates fields on an object for you using the proper Set methods,
919 skipping unchanged values.
921 ARGSRef => a hashref of attributes => value for the update
922 AttributesRef => an arrayref of keys in ARGSRef that should be updated
923 AttributePrefix => a prefix that should be added to the attributes in AttributesRef
924 when looking up values in ARGSRef
925 Bare attributes are tried before prefixed attributes
927 Returns a list of localized results of the update
936 AttributesRef => undef,
937 AttributePrefix => undef,
941 my $attributes = $args{'AttributesRef'};
942 my $ARGSRef = $args{'ARGSRef'};
945 # gather all new values
946 foreach my $attribute (@$attributes) {
948 if ( defined $ARGSRef->{$attribute} ) {
949 $value = $ARGSRef->{$attribute};
952 defined( $args{'AttributePrefix'} )
954 $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute }
957 $value = $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute };
964 $value =~ s/\r\n/\n/gs;
966 my $truncated_value = $self->TruncateValue($attribute, $value);
968 # If Queue is 'General', we want to resolve the queue name for
971 # This is in an eval block because $object might not exist.
972 # and might not have a Name method. But "can" won't find autoloaded
973 # items. If it fails, we don't care
975 no warnings "uninitialized";
978 my $object = $attribute . "Obj";
979 $self->$object->Name;
982 next if $name eq $value || $name eq ($value || 0);
985 next if $truncated_value eq $self->$attribute();
986 next if ( $truncated_value || 0 ) eq $self->$attribute();
989 $new_values{$attribute} = $value;
992 return $self->_UpdateAttributes(
993 Attributes => $attributes,
994 NewValues => \%new_values,
998 sub _UpdateAttributes {
1008 foreach my $attribute (@{ $args{Attributes} }) {
1009 next if !exists($args{NewValues}{$attribute});
1011 my $value = $args{NewValues}{$attribute};
1012 my $method = "Set$attribute";
1013 my ( $code, $msg ) = $self->$method($value);
1014 my ($prefix) = ref($self) =~ /RT(?:.*)::(\w+)/;
1016 # Default to $id, but use name if we can get it.
1017 my $label = $self->id;
1018 $label = $self->Name if (UNIVERSAL::can($self,'Name'));
1019 # this requires model names to be loc'ed.
1030 push @results, $self->loc( $prefix ) . " $label: ". $msg;
1034 "[_1] could not be set to [_2].", # loc
1035 "That is already the current value", # loc
1036 "No value sent to _Set!", # loc
1037 "Illegal value for [_1]", # loc
1038 "The new value has been set.", # loc
1039 "No column specified", # loc
1040 "Immutable field", # loc
1041 "Nonexistant field?", # loc
1042 "Invalid data", # loc
1043 "Couldn't find row", # loc
1044 "Missing a primary key?: [_1]", # loc
1045 "Found Object", # loc
1059 This returns an RT::Links object which references all the tickets
1060 which are 'MembersOf' this ticket
1066 return ( $self->_Links( 'Target', 'MemberOf' ) );
1073 This returns an RT::Links object which references all the tickets that this
1074 ticket is a 'MemberOf'
1080 return ( $self->_Links( 'Base', 'MemberOf' ) );
1087 This returns an RT::Links object which shows all references for which this ticket is a base
1093 return ( $self->_Links( 'Base', 'RefersTo' ) );
1100 This returns an L<RT::Links> object which shows all references for which this ticket is a target
1106 return ( $self->_Links( 'Target', 'RefersTo' ) );
1113 This returns an RT::Links object which references all the tickets that depend on this one
1119 return ( $self->_Links( 'Target', 'DependsOn' ) );
1125 =head2 HasUnresolvedDependencies
1127 Takes a paramhash of Type (default to '__any'). Returns the number of
1128 unresolved dependencies, if $self->UnresolvedDependencies returns an
1129 object with one or more members of that type. Returns false
1134 sub HasUnresolvedDependencies {
1141 my $deps = $self->UnresolvedDependencies;
1144 $deps->LimitType( VALUE => $args{Type} );
1149 if ($deps->Count > 0) {
1150 return $deps->Count;
1159 =head2 UnresolvedDependencies
1161 Returns an RT::Tickets object of tickets which this ticket depends on
1162 and which have a status of new, open or stalled. (That list comes from
1163 RT::Queue->ActiveStatusArray
1168 sub UnresolvedDependencies {
1170 my $deps = RT::Tickets->new($self->CurrentUser);
1172 $deps->LimitToActiveStatus;
1173 $deps->LimitDependedOnBy($self->Id);
1181 =head2 AllDependedOnBy
1183 Returns an array of RT::Ticket objects which (directly or indirectly)
1184 depends on this ticket; takes an optional 'Type' argument in the param
1185 hash, which will limit returned tickets to that type, as well as cause
1186 tickets with that type to serve as 'leaf' nodes that stops the recursive
1191 sub AllDependedOnBy {
1193 return $self->_AllLinkedTickets( LinkType => 'DependsOn',
1194 Direction => 'Target', @_ );
1199 Returns an array of RT::Ticket objects which this ticket (directly or
1200 indirectly) depends on; takes an optional 'Type' argument in the param
1201 hash, which will limit returned tickets to that type, as well as cause
1202 tickets with that type to serve as 'leaf' nodes that stops the
1203 recursive dependency search.
1209 return $self->_AllLinkedTickets( LinkType => 'DependsOn',
1210 Direction => 'Base', @_ );
1213 sub _AllLinkedTickets {
1225 my $dep = $self->_Links( $args{Direction}, $args{LinkType});
1226 while (my $link = $dep->Next()) {
1227 my $uri = $args{Direction} eq 'Target' ? $link->BaseURI : $link->TargetURI;
1228 next unless ($uri->IsLocal());
1229 my $obj = $args{Direction} eq 'Target' ? $link->BaseObj : $link->TargetObj;
1230 next if $args{_found}{$obj->Id};
1233 $args{_found}{$obj->Id} = $obj;
1234 $obj->_AllLinkedTickets( %args, _top => 0 );
1236 elsif ($obj->Type and $obj->Type eq $args{Type}) {
1237 $args{_found}{$obj->Id} = $obj;
1240 $obj->_AllLinkedTickets( %args, _top => 0 );
1245 return map { $args{_found}{$_} } sort keys %{$args{_found}};
1256 This returns an RT::Links object which references all the tickets that this ticket depends on
1262 return ( $self->_Links( 'Base', 'DependsOn' ) );
1271 This returns an RT::Links object which references all the customers that
1272 this object is a member of. This includes both explicitly linked customers
1273 and links implied by services.
1278 my( $self, %opt ) = @_;
1279 my $Debug = $opt{'Debug'};
1281 unless ( $self->{'Customers'} ) {
1283 $self->{'Customers'} = $self->MemberOf->Clone;
1285 for my $fstable (qw(cust_main cust_svc)) {
1287 $self->{'Customers'}->Limit(
1289 OPERATOR => 'STARTSWITH',
1290 VALUE => "freeside://freeside/$fstable",
1291 ENTRYAGGREGATOR => 'OR',
1292 SUBCLAUSE => 'customers',
1297 warn "->Customers method called on $self; returning ".
1298 ref($self->{'Customers'}). ' object'
1301 return $self->{'Customers'};
1310 This returns an RT::Links object which references all the services this
1311 object is a member of.
1316 my( $self, %opt ) = @_;
1318 unless ( $self->{'Services'} ) {
1320 $self->{'Services'} = $self->MemberOf->Clone;
1322 $self->{'Services'}->Limit(
1324 OPERATOR => 'STARTSWITH',
1325 VALUE => "freeside://freeside/cust_svc",
1329 return $self->{'Services'};
1337 =head2 Links DIRECTION [TYPE]
1339 Return links (L<RT::Links>) to/from this object.
1341 DIRECTION is either 'Base' or 'Target'.
1343 TYPE is a type of links to return, it can be omitted to get
1348 sub Links { shift->_Links(@_) }
1353 #TODO: Field isn't the right thing here. but I ahave no idea what mnemonic ---
1356 my $type = shift || "";
1358 unless ( $self->{"$field$type"} ) {
1359 $self->{"$field$type"} = RT::Links->new( $self->CurrentUser );
1360 # at least to myself
1361 $self->{"$field$type"}->Limit( FIELD => $field,
1362 VALUE => $self->URI,
1363 ENTRYAGGREGATOR => 'OR' );
1364 $self->{"$field$type"}->Limit( FIELD => 'Type',
1368 return ( $self->{"$field$type"} );
1376 Takes a Type and returns a string that is more human readable.
1382 my %args = ( Type => '',
1385 $args{Type} =~ s/([A-Z])/" " . lc $1/ge;
1386 $args{Type} =~ s/^\s+//;
1395 Takes either a Target or a Base and returns a string of human friendly text.
1401 my %args = ( Object => undef,
1405 my $text = "URI " . $args{FallBack};
1406 if ($args{Object} && $args{Object}->isa("RT::Ticket")) {
1407 $text = "Ticket " . $args{Object}->id;
1414 Takes a paramhash of Type and one of Base or Target. Adds that link to this object.
1416 If Silent is true then no transactions will be recorded. You can individually
1417 control transactions on both base and target and with SilentBase and
1418 SilentTarget respectively. By default both transactions are created.
1420 If the link destination is a local object and does the
1421 L<RT::Record::Role::Status> role, this method ensures object Status is not
1422 "deleted". Linking to deleted objects is forbidden.
1424 If the link destination (i.e. not C<$self>) is a local object and the
1425 C<$StrictLinkACL> option is enabled, this method checks the appropriate right
1426 on the destination object (if any, as returned by the L</ModifyLinkRight>
1427 method). B<< The subclass is expected to check the appropriate right on the
1428 source object (i.e. C<$self>) before calling this method. >> This allows a
1429 different right to be used on the source object during creation, for example.
1431 Returns a tuple of (link ID, message, flag if link already existed).
1443 SilentBase => undef,
1444 SilentTarget => undef,
1448 # Remote_link is the URI of the object that is not this ticket
1452 if ( $args{'Base'} and $args{'Target'} ) {
1453 $RT::Logger->debug( "$self tried to create a link. both base and target were specified" );
1454 return ( 0, $self->loc("Can't specify both base and target") );
1456 elsif ( $args{'Base'} ) {
1457 $args{'Target'} = $self->URI();
1458 $remote_link = $args{'Base'};
1459 $direction = 'Target';
1461 elsif ( $args{'Target'} ) {
1462 $args{'Base'} = $self->URI();
1463 $remote_link = $args{'Target'};
1464 $direction = 'Base';
1467 return ( 0, $self->loc('Either base or target must be specified') );
1470 my $remote_uri = RT::URI->new( $self->CurrentUser );
1471 if ($remote_uri->FromURI( $remote_link )) {
1472 my $remote_obj = $remote_uri->IsLocal ? $remote_uri->Object : undef;
1473 if ($remote_obj and $remote_obj->id) {
1474 # Enforce the remote end of StrictLinkACL
1475 if (RT->Config->Get("StrictLinkACL")) {
1476 my $right = $remote_obj->ModifyLinkRight;
1478 return (0, $self->loc("Permission denied"))
1480 not $self->CurrentUser->HasRight( Right => $right, Object => $remote_obj );
1483 # Prevent linking to deleted objects
1484 if ($remote_obj->DOES("RT::Record::Role::Status")
1485 and $remote_obj->Status eq "deleted") {
1486 return (0, $self->loc("Linking to a deleted [_1] is not allowed", $self->loc(lc($remote_obj->RecordType))));
1490 return (0, $self->loc("Couldn't resolve '[_1]' into a link.", $remote_link));
1493 # Check if the link already exists - we don't want duplicates
1494 my $old_link = RT::Link->new( $self->CurrentUser );
1495 $old_link->LoadByParams( Base => $args{'Base'},
1496 Type => $args{'Type'},
1497 Target => $args{'Target'} );
1498 if ( $old_link->Id ) {
1499 $RT::Logger->debug("$self Somebody tried to duplicate a link");
1500 return ( $old_link->id, $self->loc("Link already exists"), 1 );
1503 if ( $args{'Type'} =~ /^(?:DependsOn|MemberOf)$/ ) {
1505 my @tickets = $self->_AllLinkedTickets(
1506 LinkType => $args{'Type'},
1507 Direction => $direction eq 'Target' ? 'Base' : 'Target',
1509 if ( grep { $_->id == ( $direction eq 'Target' ? $args{'Base'} : $args{'Target'} ) } @tickets ) {
1510 return ( 0, $self->loc("Refused to add link which would create a circular relationship") );
1514 # Storing the link in the DB.
1515 my $link = RT::Link->new( $self->CurrentUser );
1516 my ($linkid, $linkmsg) = $link->Create( Target => $args{Target},
1517 Base => $args{Base},
1518 Type => $args{Type} );
1521 $RT::Logger->error("Link could not be created: ".$linkmsg);
1522 return ( 0, $self->loc("Link could not be created: [_1]", $linkmsg) );
1525 my $basetext = $self->FormatLink(Object => $link->BaseObj,
1526 FallBack => $args{Base});
1527 my $targettext = $self->FormatLink(Object => $link->TargetObj,
1528 FallBack => $args{Target});
1529 my $typetext = $self->FormatType(Type => $args{Type});
1530 my $TransString = "$basetext $typetext $targettext.";
1532 # No transactions for you!
1533 return ($linkid, $TransString) if $args{'Silent'};
1535 my $opposite_direction = $direction eq 'Target' ? 'Base': 'Target';
1537 # Some transactions?
1538 unless ( $args{ 'Silent'. $direction } ) {
1539 my ( $Trans, $Msg, $TransObj ) = $self->_NewTransaction(
1541 Field => $RT::Link::DIRMAP{$args{'Type'}}->{$direction},
1542 NewValue => $remote_uri->URI || $remote_link,
1545 $RT::Logger->error("Couldn't create transaction: $Msg") unless $Trans;
1548 if ( !$args{"Silent$opposite_direction"} && $remote_uri->IsLocal ) {
1549 my $OtherObj = $remote_uri->Object;
1550 my ( $val, $msg ) = $OtherObj->_NewTransaction(
1552 Field => $RT::Link::DIRMAP{$args{'Type'}}->{$opposite_direction},
1553 NewValue => $self->URI,
1556 $RT::Logger->error("Couldn't create transaction: $msg") unless $val;
1559 return ($linkid, $TransString);
1564 Takes a paramhash of Type and one of Base or Target. Removes that link from this object.
1566 If Silent is true then no transactions will be recorded. You can individually
1567 control transactions on both base and target and with SilentBase and
1568 SilentTarget respectively. By default both transactions are created.
1570 If the link destination (i.e. not C<$self>) is a local object and the
1571 C<$StrictLinkACL> option is enabled, this method checks the appropriate right
1572 on the destination object (if any, as returned by the L</ModifyLinkRight>
1573 method). B<< The subclass is expected to check the appropriate right on the
1574 source object (i.e. C<$self>) before calling this method. >>
1576 Returns a tuple of (status flag, message).
1587 SilentBase => undef,
1588 SilentTarget => undef,
1592 # We want one of base and target. We don't care which but we only want _one_.
1596 if ( $args{'Base'} and $args{'Target'} ) {
1597 $RT::Logger->debug("$self ->_DeleteLink. got both Base and Target");
1598 return ( 0, $self->loc("Can't specify both base and target") );
1600 elsif ( $args{'Base'} ) {
1601 $args{'Target'} = $self->URI();
1602 $remote_link = $args{'Base'};
1603 $direction = 'Target';
1605 elsif ( $args{'Target'} ) {
1606 $args{'Base'} = $self->URI();
1607 $remote_link = $args{'Target'};
1608 $direction = 'Base';
1611 $RT::Logger->error("Base or Target must be specified");
1612 return ( 0, $self->loc('Either base or target must be specified') );
1615 my $remote_uri = RT::URI->new( $self->CurrentUser );
1616 if ($remote_uri->FromURI( $remote_link )) {
1617 # Enforce the remote end of StrictLinkACL
1618 my $remote_obj = $remote_uri->IsLocal ? $remote_uri->Object : undef;
1619 if ($remote_obj and $remote_obj->id and RT->Config->Get("StrictLinkACL")) {
1620 my $right = $remote_obj->ModifyLinkRight;
1622 return (0, $self->loc("Permission denied"))
1624 not $self->CurrentUser->HasRight( Right => $right, Object => $remote_obj );
1627 return (0, $self->loc("Couldn't resolve '[_1]' into a link.", $remote_link));
1630 my $link = RT::Link->new( $self->CurrentUser );
1631 $RT::Logger->debug( "Trying to load link: "
1632 . $args{'Base'} . " "
1633 . $args{'Type'} . " "
1634 . $args{'Target'} );
1636 $link->LoadByParams(
1637 Base => $args{'Base'},
1638 Type => $args{'Type'},
1639 Target => $args{'Target'}
1642 unless ($link->id) {
1643 $RT::Logger->debug("Couldn't find that link");
1644 return ( 0, $self->loc("Link not found") );
1647 my $basetext = $self->FormatLink(Object => $link->BaseObj,
1648 FallBack => $args{Base});
1649 my $targettext = $self->FormatLink(Object => $link->TargetObj,
1650 FallBack => $args{Target});
1651 my $typetext = $self->FormatType(Type => $args{Type});
1652 my $TransString = "$basetext no longer $typetext $targettext.";
1654 my ($ok, $msg) = $link->Delete();
1656 RT->Logger->error("Link could not be deleted: $msg");
1657 return ( 0, $self->loc("Link could not be deleted: [_1]", $msg) );
1660 # No transactions for you!
1661 return (1, $TransString) if $args{'Silent'};
1663 my $opposite_direction = $direction eq 'Target' ? 'Base': 'Target';
1665 # Some transactions?
1666 unless ( $args{ 'Silent'. $direction } ) {
1667 my ( $Trans, $Msg, $TransObj ) = $self->_NewTransaction(
1668 Type => 'DeleteLink',
1669 Field => $RT::Link::DIRMAP{$args{'Type'}}->{$direction},
1670 OldValue => $remote_uri->URI || $remote_link,
1673 $RT::Logger->error("Couldn't create transaction: $Msg") unless $Trans;
1676 if ( !$args{"Silent$opposite_direction"} && $remote_uri->IsLocal ) {
1677 my $OtherObj = $remote_uri->Object;
1678 my ( $val, $msg ) = $OtherObj->_NewTransaction(
1679 Type => 'DeleteLink',
1680 Field => $RT::Link::DIRMAP{$args{'Type'}}->{$opposite_direction},
1681 OldValue => $self->URI,
1684 $RT::Logger->error("Couldn't create transaction: $msg") unless $val;
1687 return (1, $TransString);
1690 =head1 LockForUpdate
1692 In a database transaction, gains an exclusive lock on the row, to
1693 prevent race conditions. On SQLite, this is a "RESERVED" lock on the
1701 my $pk = $self->_PrimaryKey;
1702 my $id = @_ ? $_[0] : $self->$pk;
1703 $self->_expire if $self->isa("DBIx::SearchBuilder::Record::Cachable");
1704 if (RT->Config->Get('DatabaseType') eq "SQLite") {
1705 # SQLite does DB-level locking, upgrading the transaction to
1706 # "RESERVED" on the first UPDATE/INSERT/DELETE. Do a no-op
1707 # UPDATE to force the upgade.
1708 return RT->DatabaseHandle->dbh->do(
1709 "UPDATE " .$self->Table.
1710 " SET $pk = $pk WHERE 1 = 0");
1712 return $self->_LoadFromSQL(
1713 "SELECT * FROM ".$self->Table
1714 ." WHERE $pk = ? FOR UPDATE",
1720 =head2 _NewTransaction PARAMHASH
1722 Private function to create a new RT::Transaction object for this ticket update
1726 sub _NewTransaction {
1733 OldReference => undef,
1734 NewReference => undef,
1735 ReferenceType => undef,
1739 ActivateScrips => 1,
1741 SquelchMailTo => undef,
1746 my $in_txn = RT->DatabaseHandle->TransactionDepth;
1747 RT->DatabaseHandle->BeginTransaction unless $in_txn;
1749 $self->LockForUpdate;
1751 my $old_ref = $args{'OldReference'};
1752 my $new_ref = $args{'NewReference'};
1753 my $ref_type = $args{'ReferenceType'};
1754 if ($old_ref or $new_ref) {
1755 $ref_type ||= ref($old_ref) || ref($new_ref);
1757 $RT::Logger->error("Reference type not specified for transaction");
1760 $old_ref = $old_ref->Id if ref($old_ref);
1761 $new_ref = $new_ref->Id if ref($new_ref);
1764 require RT::Transaction;
1765 my $trans = RT::Transaction->new( $self->CurrentUser );
1766 my ( $transaction, $msg ) = $trans->Create(
1767 ObjectId => $self->Id,
1768 ObjectType => ref($self),
1769 TimeTaken => $args{'TimeTaken'},
1770 Type => $args{'Type'},
1771 Data => $args{'Data'},
1772 Field => $args{'Field'},
1773 NewValue => $args{'NewValue'},
1774 OldValue => $args{'OldValue'},
1775 NewReference => $new_ref,
1776 OldReference => $old_ref,
1777 ReferenceType => $ref_type,
1778 MIMEObj => $args{'MIMEObj'},
1779 ActivateScrips => $args{'ActivateScrips'},
1780 CommitScrips => $args{'CommitScrips'},
1781 SquelchMailTo => $args{'SquelchMailTo'},
1782 CustomFields => $args{'CustomFields'},
1785 # Rationalize the object since we may have done things to it during the caching.
1786 $self->Load($self->Id);
1788 $RT::Logger->warning($msg) unless $transaction;
1790 $self->_SetLastUpdated;
1792 if ( defined $args{'TimeTaken'} and $self->can('_UpdateTimeTaken')) {
1793 $self->_UpdateTimeTaken( $args{'TimeTaken'}, Transaction => $trans );
1795 if ( RT->Config->Get('UseTransactionBatch') and $transaction ) {
1796 push @{$self->{_TransactionBatch}}, $trans if $args{'CommitScrips'};
1799 RT->DatabaseHandle->Commit unless $in_txn;
1801 return ( $transaction, $msg, $trans );
1808 Returns an L<RT::Transactions> object of all transactions on this record object
1815 my $transactions = RT::Transactions->new( $self->CurrentUser );
1816 $transactions->Limit(
1817 FIELD => 'ObjectId',
1820 $transactions->Limit(
1821 FIELD => 'ObjectType',
1822 VALUE => ref($self),
1825 return $transactions;
1828 =head2 SortedTransactions
1830 Returns the result of L</Transactions> ordered per the
1831 I<OldestTransactionsFirst> preference/option.
1835 sub SortedTransactions {
1837 my $txns = $self->Transactions;
1838 my $order = RT->Config->Get("OldestTransactionsFirst", $self->CurrentUser)
1841 { FIELD => 'Created', ORDER => $order },
1842 { FIELD => 'id', ORDER => $order },
1847 our %TRANSACTION_CLASSIFICATION = (
1848 Create => 'message',
1849 Correspond => 'message',
1850 Comment => 'message',
1852 AddWatcher => 'people',
1853 DelWatcher => 'people',
1862 DeleteLink => 'links',
1866 __default => 'basics',
1867 map( { $_ => 'dates' } qw(
1868 Told Starts Started Due LastUpdated Created LastUpdated
1870 map( { $_ => 'people' } qw(
1871 Owner Creator LastUpdatedBy
1874 SystemError => 'error',
1875 AttachmentTruncate => 'attachment-truncate',
1876 AttachmentDrop => 'attachment-drop',
1877 AttachmentError => 'error',
1878 __default => 'other',
1881 sub ClassifyTransaction {
1885 my $type = $txn->Type;
1887 my $res = $TRANSACTION_CLASSIFICATION{ $type };
1888 return $res || $TRANSACTION_CLASSIFICATION{ '__default' }
1891 return $res->{ $txn->Field } || $res->{'__default'}
1892 || $TRANSACTION_CLASSIFICATION{ '__default' };
1897 Returns an L<RT::Attachments> object of all attachments on this record object
1898 (for all its L</Transactions>).
1900 By default Content and Headers of attachments are not fetched right away from
1901 database. Use C<WithContent> and C<WithHeaders> options to override this.
1912 my @columns = grep { not /^(Headers|Content)$/ }
1913 RT::Attachment->ReadableAttributes;
1914 push @columns, 'Headers' if $args{'WithHeaders'};
1915 push @columns, 'Content' if $args{'WithContent'};
1917 my $res = RT::Attachments->new( $self->CurrentUser );
1918 $res->Columns( @columns );
1919 my $txn_alias = $res->TransactionAlias;
1921 ALIAS => $txn_alias,
1922 FIELD => 'ObjectType',
1923 VALUE => ref($self),
1926 ALIAS => $txn_alias,
1927 FIELD => 'ObjectId',
1933 =head2 TextAttachments
1935 Returns an L<RT::Attachments> object of all attachments, like L<Attachments>,
1936 but only those that are text.
1938 By default Content and Headers are fetched. Use C<WithContent> and
1939 C<WithHeaders> options to override this.
1943 sub TextAttachments {
1945 my $res = $self->Attachments(
1950 $res->Limit( FIELD => 'ContentType', OPERATOR => '=', VALUE => 'text/plain');
1951 $res->Limit( FIELD => 'ContentType', OPERATOR => 'STARTSWITH', VALUE => 'message/');
1952 $res->Limit( FIELD => 'ContentType', OPERATOR => '=', VALUE => 'text');
1953 $res->Limit( FIELD => 'Filename', OPERATOR => 'IS', VALUE => 'NULL')
1954 if RT->Config->Get( 'SuppressInlineTextFiles', $self->CurrentUser );
1960 my $cfs = RT::CustomFields->new( $self->CurrentUser );
1962 $cfs->SetContextObject( $self );
1963 # XXX handle multiple types properly
1964 $cfs->LimitToLookupType( $self->CustomFieldLookupType );
1965 $cfs->LimitToGlobalOrObjectId( $self->CustomFieldLookupId );
1966 $cfs->ApplySortOrder;
1971 # TODO: This _only_ works for RT::Foo classes. it doesn't work, for
1972 # example, for RT::IR::Foo classes.
1974 sub CustomFieldLookupId {
1976 my $lookup = shift || $self->CustomFieldLookupType;
1977 my @classes = ($lookup =~ /RT::(\w+)-/g);
1979 # Work on "RT::Queue", for instance
1980 return $self->Id unless @classes;
1983 # Save a ->Load call by not calling ->FooObj->Id, just ->Foo
1984 my $final = shift @classes;
1985 foreach my $class (reverse @classes) {
1986 my $method = "${class}Obj";
1987 $object = $object->$method;
1990 my $id = $object->$final;
1991 unless (defined $id) {
1992 my $method = "${final}Obj";
1993 $id = $object->$method->Id;
1999 =head2 CustomFieldLookupType
2001 Returns the path RT uses to figure out which custom fields apply to this object.
2005 sub CustomFieldLookupType {
2007 return ref($self) || $self;
2011 =head2 AddCustomFieldValue { Field => FIELD, Value => VALUE }
2013 VALUE should be a string. FIELD can be any identifier of a CustomField
2014 supported by L</LoadCustomFieldByIdentifier> method.
2016 Adds VALUE as a value of CustomField FIELD. If this is a single-value custom field,
2017 deletes the old value.
2018 If VALUE is not a valid value for the custom field, returns
2019 (0, 'Error message' ) otherwise, returns ($id, 'Success Message') where
2020 $id is ID of created L<ObjectCustomFieldValue> object.
2024 sub AddCustomFieldValue {
2026 $self->_AddCustomFieldValue(@_);
2029 sub _AddCustomFieldValue {
2034 LargeContent => undef,
2035 ContentType => undef,
2036 RecordTransaction => 1,
2040 my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
2041 unless ( $cf->Id ) {
2042 return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
2045 my $OCFs = $self->CustomFields;
2046 $OCFs->Limit( FIELD => 'id', VALUE => $cf->Id );
2047 unless ( $OCFs->Count ) {
2051 "Custom field [_1] does not apply to this object",
2052 ref $args{'Field'} ? $args{'Field'}->id : $args{'Field'}
2057 # empty string is not correct value of any CF, so undef it
2058 foreach ( qw(Value LargeContent) ) {
2059 $args{ $_ } = undef if defined $args{ $_ } && !length $args{ $_ };
2062 unless ( $cf->ValidateValue( $args{'Value'} ) ) {
2063 return ( 0, $self->loc("Invalid value for custom field") );
2066 # If the custom field only accepts a certain # of values, delete the existing
2067 # value and record a "changed from foo to bar" transaction
2068 unless ( $cf->UnlimitedValues ) {
2070 # Load up a ObjectCustomFieldValues object for this custom field and this ticket
2071 my $values = $cf->ValuesForObject($self);
2073 # We need to whack any old values here. In most cases, the custom field should
2074 # only have one value to delete. In the pathalogical case, this custom field
2075 # used to be a multiple and we have many values to whack....
2076 my $cf_values = $values->Count;
2078 if ( $cf_values > $cf->MaxValues ) {
2079 my $i = 0; #We want to delete all but the max we can currently have , so we can then
2080 # execute the same code to "change" the value from old to new
2081 while ( my $value = $values->Next ) {
2083 if ( $i < $cf_values ) {
2084 my ( $val, $msg ) = $cf->DeleteValueForObject(
2091 my ( $TransactionId, $Msg, $TransactionObj ) =
2092 $self->_NewTransaction(
2093 Type => 'CustomField',
2095 OldReference => $value,
2099 $values->RedoSearch if $i; # redo search if have deleted at least one value
2102 if ( my $entry = $values->HasEntry($args{'Value'}, $args{'LargeContent'}) ) {
2106 my $old_value = $values->First;
2108 $old_content = $old_value->Content if $old_value;
2110 my ( $new_value_id, $value_msg ) = $cf->AddValueForObject(
2112 Content => $args{'Value'},
2113 LargeContent => $args{'LargeContent'},
2114 ContentType => $args{'ContentType'},
2117 unless ( $new_value_id ) {
2118 return ( 0, $self->loc( "Could not add new custom field value: [_1]", $value_msg ) );
2121 my $new_value = RT::ObjectCustomFieldValue->new( $self->CurrentUser );
2122 $new_value->Load( $new_value_id );
2124 # now that adding the new value was successful, delete the old one
2126 my ( $val, $msg ) = $old_value->Delete();
2127 return ( 0, $msg ) unless $val;
2130 if ( $args{'RecordTransaction'} ) {
2131 my ( $TransactionId, $Msg, $TransactionObj ) =
2132 $self->_NewTransaction(
2133 Type => 'CustomField',
2135 OldReference => $old_value,
2136 NewReference => $new_value,
2140 my $new_content = $new_value->Content;
2142 # For datetime, we need to display them in "human" format in result message
2143 #XXX TODO how about date without time?
2144 if ($cf->Type eq 'DateTime') {
2145 my $DateObj = RT::Date->new( $self->CurrentUser );
2148 Value => $new_content,
2150 $new_content = $DateObj->AsString;
2152 if ( defined $old_content && length $old_content ) {
2155 Value => $old_content,
2157 $old_content = $DateObj->AsString;
2161 unless ( defined $old_content && length $old_content ) {
2162 return ( $new_value_id, $self->loc( "[_1] [_2] added", $cf->Name, $new_content ));
2164 elsif ( !defined $new_content || !length $new_content ) {
2165 return ( $new_value_id,
2166 $self->loc( "[_1] [_2] deleted", $cf->Name, $old_content ) );
2169 return ( $new_value_id, $self->loc( "[_1] [_2] changed to [_3]", $cf->Name, $old_content, $new_content));
2174 # otherwise, just add a new value and record "new value added"
2176 my $values = $cf->ValuesForObject($self);
2177 if ( my $entry = $values->HasEntry($args{'Value'}, $args{'LargeContent'}) ) {
2181 my ($new_value_id, $msg) = $cf->AddValueForObject(
2183 Content => $args{'Value'},
2184 LargeContent => $args{'LargeContent'},
2185 ContentType => $args{'ContentType'},
2188 unless ( $new_value_id ) {
2189 return ( 0, $self->loc( "Could not add new custom field value: [_1]", $msg ) );
2191 if ( $args{'RecordTransaction'} ) {
2192 my ( $tid, $msg ) = $self->_NewTransaction(
2193 Type => 'CustomField',
2195 NewReference => $new_value_id,
2196 ReferenceType => 'RT::ObjectCustomFieldValue',
2199 return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $msg ) );
2202 return ( $new_value_id, $self->loc( "[_1] added as a value for [_2]", $args{'Value'}, $cf->Name ) );
2208 =head2 DeleteCustomFieldValue { Field => FIELD, Value => VALUE }
2210 Deletes VALUE as a value of CustomField FIELD.
2212 VALUE can be a string, a CustomFieldValue or a ObjectCustomFieldValue.
2214 If VALUE is not a valid value for the custom field, returns
2215 (0, 'Error message' ) otherwise, returns (1, 'Success Message')
2219 sub DeleteCustomFieldValue {
2228 my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
2229 unless ( $cf->Id ) {
2230 return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
2233 my ( $val, $msg ) = $cf->DeleteValueForObject(
2235 Id => $args{'ValueId'},
2236 Content => $args{'Value'},
2242 my ( $TransactionId, $Msg, $TransactionObj ) = $self->_NewTransaction(
2243 Type => 'CustomField',
2245 OldReference => $val,
2246 ReferenceType => 'RT::ObjectCustomFieldValue',
2248 unless ($TransactionId) {
2249 return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $Msg ) );
2252 my $old_value = $TransactionObj->OldValue;
2253 # For datetime, we need to display them in "human" format in result message
2254 if ( $cf->Type eq 'DateTime' ) {
2255 my $DateObj = RT::Date->new( $self->CurrentUser );
2258 Value => $old_value,
2260 $old_value = $DateObj->AsString;
2265 "[_1] is no longer a value for custom field [_2]",
2266 $old_value, $cf->Name
2273 =head2 FirstCustomFieldValue FIELD
2275 Return the content of the first value of CustomField FIELD for this ticket
2276 Takes a field id or name
2280 sub FirstCustomFieldValue {
2284 my $values = $self->CustomFieldValues( $field );
2285 return undef unless my $first = $values->First;
2286 return $first->Content;
2289 =head2 CustomFieldValuesAsString FIELD
2291 Return the content of the CustomField FIELD for this ticket.
2292 If this is a multi-value custom field, values will be joined with newlines.
2294 Takes a field id or name as the first argument
2296 Takes an optional Separator => "," second and third argument
2297 if you want to join the values using something other than a newline
2301 sub CustomFieldValuesAsString {
2305 my $separator = $args{Separator} || "\n";
2307 my $values = $self->CustomFieldValues( $field );
2308 return join ($separator, grep { defined $_ }
2309 map { $_->Content } @{$values->ItemsArrayRef});
2314 =head2 CustomFieldValues FIELD
2316 Return a ObjectCustomFieldValues object of all values of the CustomField whose
2317 id or Name is FIELD for this record.
2319 Returns an RT::ObjectCustomFieldValues object
2323 sub CustomFieldValues {
2328 my $cf = $self->LoadCustomFieldByIdentifier( $field );
2330 # we were asked to search on a custom field we couldn't find
2331 unless ( $cf->id ) {
2332 $RT::Logger->warning("Couldn't load custom field by '$field' identifier");
2333 return RT::ObjectCustomFieldValues->new( $self->CurrentUser );
2335 return ( $cf->ValuesForObject($self) );
2338 # we're not limiting to a specific custom field;
2339 my $ocfs = RT::ObjectCustomFieldValues->new( $self->CurrentUser );
2340 $ocfs->LimitToObject( $self );
2344 =head2 LoadCustomFieldByIdentifier IDENTIFER
2346 Find the custom field has id or name IDENTIFIER for this object.
2348 If no valid field is found, returns an empty RT::CustomField object.
2352 sub LoadCustomFieldByIdentifier {
2357 if ( UNIVERSAL::isa( $field, "RT::CustomField" ) ) {
2358 $cf = RT::CustomField->new($self->CurrentUser);
2359 $cf->SetContextObject( $self );
2360 $cf->LoadById( $field->id );
2362 elsif ($field =~ /^\d+$/) {
2363 $cf = RT::CustomField->new($self->CurrentUser);
2364 $cf->SetContextObject( $self );
2365 $cf->LoadById($field);
2368 my $cfs = $self->CustomFields($self->CurrentUser);
2369 $cfs->SetContextObject( $self );
2370 $cfs->Limit(FIELD => 'Name', VALUE => $field, CASESENSITIVE => 0);
2371 $cf = $cfs->First || RT::CustomField->new($self->CurrentUser);
2376 sub ACLEquivalenceObjects { }
2380 Takes a paramhash with the attributes 'Right' and 'Principal'
2381 'Right' is a ticket-scoped textual right from RT::ACE
2382 'Principal' is an RT::User object
2384 Returns 1 if the principal has the right. Returns undef if not.
2396 $args{Principal} ||= $self->CurrentUser->PrincipalObj;
2398 return $args{'Principal'}->HasRight(
2399 Object => $self->Id ? $self : $RT::System,
2400 Right => $args{'Right'}
2404 sub CurrentUserHasRight {
2406 return $self->HasRight( Right => @_ );
2409 sub ModifyLinkRight { }
2411 =head2 ColumnMapClassName
2413 ColumnMap needs a massaged collection class name to load the correct list
2414 display. Equivalent to L<RT::SearchBuilder/ColumnMapClassName>, but provided
2415 for a record instead of a collection.
2417 Returns a string. May be called as a package method.
2421 sub ColumnMapClassName {
2423 my $Class = ref($self) || $self;
2428 sub BasicColumns { }
2431 return RT->Config->Get('WebPath'). "/index.html?q=";
2436 return undef unless defined $self->Id;
2437 return "@{[ref $self]}-$RT::Organization-@{[$self->Id]}";
2440 sub FindDependencies {
2442 my ($walker, $deps) = @_;
2443 for my $col (qw/Creator LastUpdatedBy/) {
2444 if ( $self->_Accessible( $col, 'read' ) ) {
2445 next unless $self->$col;
2446 my $obj = RT::Principal->new( $self->CurrentUser );
2447 $obj->Load( $self->$col );
2448 $deps->Add( out => $obj->Object );
2452 # Object attributes, we have to check on every object
2453 my $objs = $self->Attributes;
2454 $deps->Add( in => $objs );
2457 if ( $self->isa("RT::Ticket")
2458 or $self->isa("RT::User")
2459 or $self->isa("RT::Group")
2460 or $self->isa("RT::Article")
2461 or $self->isa("RT::Queue") )
2463 $objs = RT::Transactions->new( $self->CurrentUser );
2464 $objs->Limit( FIELD => 'ObjectType', VALUE => ref $self );
2465 $objs->Limit( FIELD => 'ObjectId', VALUE => $self->id );
2466 $deps->Add( in => $objs );
2469 # Object custom field values
2470 if (( $self->isa("RT::Transaction")
2471 or $self->isa("RT::Ticket")
2472 or $self->isa("RT::User")
2473 or $self->isa("RT::Group")
2474 or $self->isa("RT::Queue")
2475 or $self->isa("RT::Article") )
2476 and $self->can("CustomFieldValues") )
2478 $objs = $self->CustomFieldValues; # Actually OCFVs
2479 $objs->{find_expired_rows} = 1;
2480 $deps->Add( in => $objs );
2484 if ( $self->isa("RT::Group")
2485 or $self->isa("RT::Class")
2486 or $self->isa("RT::Queue")
2487 or $self->isa("RT::CustomField") )
2489 $objs = RT::ACL->new( $self->CurrentUser );
2490 $objs->LimitToObject( $self );
2491 $deps->Add( in => $objs );
2503 Creator => "CreatorObj",
2504 LastUpdatedBy => "LastUpdatedByObj",
2505 %{ $args{Methods} || {} },
2508 my %values = %{$self->{values}};
2510 my %ca = %{ $self->_ClassAccessible };
2511 my @cols = grep {exists $values{lc $_} and defined $values{lc $_}} keys %ca;
2514 $store{$_} = $values{lc $_} for @cols;
2515 $store{id} = $values{id}; # Explicitly necessary in some cases
2517 # Un-apply the _transfer_ encoding, but don't mess with the octets
2518 # themselves. Calling ->Content directly would, in some cases,
2519 # decode from some mostly-unknown character set -- which reversing
2520 # on the far end would be complicated.
2521 if ($ca{ContentEncoding} and $ca{ContentType}) {
2522 my ($content_col) = grep {exists $ca{$_}} qw/LargeContent Content/;
2523 $store{$content_col} = $self->_DecodeLOB(
2524 "application/octet-stream", # Lie so that we get bytes, not characters
2525 $self->ContentEncoding,
2526 $self->_Value( $content_col, decode_utf8 => 0 )
2528 delete $store{ContentEncoding};
2530 return %store unless $args{UIDs};
2532 # Use FooObj to turn Foo into a reference to the UID
2533 for my $col ( grep {$store{$_}} @cols ) {
2534 my $method = $methods{$col};
2537 $method =~ s/(Id)?$/Obj/;
2539 next unless $self->can($method);
2541 my $obj = $self->$method;
2542 next unless $obj and $obj->isa("RT::Record");
2543 $store{$col} = \($obj->UID);
2546 # Anything on an object should get the UID stored instead
2547 if ($store{ObjectType} and $store{ObjectId} and $self->can("Object")) {
2548 delete $store{$_} for qw/ObjectType ObjectId/;
2549 $store{Object} = \($self->Object->UID);
2557 my ($importer, $uid, $data) = @_;
2559 my $ca = $class->_ClassAccessible;
2562 if ($ca{ContentEncoding} and $ca{ContentType}) {
2563 my ($content_col) = grep {exists $ca{$_}} qw/LargeContent Content/;
2564 if (defined $data->{$content_col}) {
2565 my ($ContentEncoding, $Content) = $class->_EncodeLOB(
2566 $data->{$content_col}, $data->{ContentType},
2568 $data->{ContentEncoding} = $ContentEncoding;
2569 $data->{$content_col} = $Content;
2573 if ($data->{Object} and not $ca{Object}) {
2574 my $ref_uid = ${ delete $data->{Object} };
2575 my $ref = $importer->Lookup( $ref_uid );
2577 my ($class, $id) = @{$ref};
2578 $data->{ObjectId} = $id;
2579 $data->{ObjectType} = $class;
2581 $data->{ObjectId} = 0;
2582 $data->{ObjectType} = "";
2583 $importer->Postpone(
2586 column => "ObjectId",
2587 classcolumn => "ObjectType",
2592 for my $col (keys %{$data}) {
2593 if (ref $data->{$col}) {
2594 my $ref_uid = ${ $data->{$col} };
2595 my $ref = $importer->Lookup( $ref_uid );
2597 my (undef, $id) = @{$ref};
2598 $data->{$col} = $id;
2601 $importer->Postpone(
2616 =head2 _AsInsertQuery
2618 Returns INSERT query string that duplicates current record and
2619 can be used to insert record back into DB after delete.
2627 my $dbh = $RT::Handle->dbh;
2629 my $res = "INSERT INTO ". $dbh->quote_identifier( $self->Table );
2630 my $values = $self->{'values'};
2631 $res .= "(". join( ",", map { $dbh->quote_identifier( $_ ) } sort keys %$values ) .")";
2633 $res .= "(". join( ",", map { $dbh->quote( $values->{$_} ) } sort keys %$values ) .")";
2639 sub BeforeWipeout { return 1 }
2643 Returns L<RT::Shredder::Dependencies> object.
2652 Flags => RT::Shredder::Constants::DEPENDS_ON,
2656 unless( $self->id ) {
2657 RT::Shredder::Exception->throw('Object is not loaded');
2660 my $deps = RT::Shredder::Dependencies->new();
2661 if( $args{'Flags'} & RT::Shredder::Constants::DEPENDS_ON ) {
2662 $self->__DependsOn( %args, Dependencies => $deps );
2672 Dependencies => undef,
2675 my $deps = $args{'Dependencies'};
2678 # Object custom field values
2679 my $objs = $self->CustomFieldValues;
2680 $objs->{'find_expired_rows'} = 1;
2681 push( @$list, $objs );
2684 $objs = $self->Attributes;
2685 push( @$list, $objs );
2688 $objs = RT::Transactions->new( $self->CurrentUser );
2689 $objs->Limit( FIELD => 'ObjectType', VALUE => ref $self );
2690 $objs->Limit( FIELD => 'ObjectId', VALUE => $self->id );
2691 push( @$list, $objs );
2694 if ( $self->can('Links') ) {
2695 # make sure we don't skip any record
2696 no warnings 'redefine';
2697 local *RT::Links::IsValidLink = sub { 1 };
2699 foreach ( qw(Base Target) ) {
2700 my $objs = $self->Links( $_ );
2702 push @$list, $objs->ItemsArrayRef;
2707 $objs = RT::ACL->new( $self->CurrentUser );
2708 $objs->LimitToObject( $self );
2709 push( @$list, $objs );
2711 $deps->_PushDependencies(
2712 BaseObject => $self,
2713 Flags => RT::Shredder::Constants::DEPENDS_ON,
2714 TargetObjects => $list,
2715 Shredder => $args{'Shredder'}
2720 # implement proxy method because some RT classes
2721 # override Delete method
2725 my $msg = $self->UID ." wiped out";
2726 $self->SUPER::Delete;
2727 $RT::Logger->info( $msg );
2731 RT::Base->_ImportOverlays();