1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2015 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
75 our $_TABLE_ATTR = { };
76 use base RT->Config->Get('RecordBaseClass');
82 $self->_BuildTableAttributes unless ($_TABLE_ATTR->{ref($self)});
83 $self->CurrentUser(@_);
90 The primary keys for RT classes is 'id'
94 sub _PrimaryKeys { return ['id'] }
95 # short circuit many, many thousands of calls from searchbuilder
96 sub _PrimaryKey { 'id' }
100 Override L<DBIx::SearchBuilder/Id> to avoid a few lookups RT doesn't do
101 on a very common codepath
103 C<id> is an alias to C<Id> and is the preferred way to call this method.
108 return shift->{'values'}->{id};
115 Delete this record object from the database.
121 my ($rv) = $self->SUPER::Delete;
123 return ($rv, $self->loc("Object deleted"));
126 return(0, $self->loc("Object could not be deleted"))
132 Returns a string which is this object's type. The type is the class,
133 without the "RT::" prefix.
140 if (ref($self) =~ /^.*::(\w+)$/) {
141 return $self->loc($1);
143 return $self->loc(ref($self));
149 Return this object's attributes as an RT::Attributes object
155 unless ($self->{'attributes'}) {
156 $self->{'attributes'} = RT::Attributes->new($self->CurrentUser);
157 $self->{'attributes'}->LimitToObject($self);
158 $self->{'attributes'}->OrderByCols({FIELD => 'id'});
160 return ($self->{'attributes'});
164 =head2 AddAttribute { Name, Description, Content }
166 Adds a new attribute for this object.
172 my %args = ( Name => undef,
173 Description => undef,
177 my $attr = RT::Attribute->new( $self->CurrentUser );
178 my ( $id, $msg ) = $attr->Create(
180 Name => $args{'Name'},
181 Description => $args{'Description'},
182 Content => $args{'Content'} );
185 # XXX TODO: Why won't RedoSearch work here?
186 $self->Attributes->_DoSearch;
192 =head2 SetAttribute { Name, Description, Content }
194 Like AddAttribute, but replaces all existing attributes with the same Name.
200 my %args = ( Name => undef,
201 Description => undef,
205 my @AttributeObjs = $self->Attributes->Named( $args{'Name'} )
206 or return $self->AddAttribute( %args );
208 my $AttributeObj = pop( @AttributeObjs );
209 $_->Delete foreach @AttributeObjs;
211 $AttributeObj->SetDescription( $args{'Description'} );
212 $AttributeObj->SetContent( $args{'Content'} );
214 $self->Attributes->RedoSearch;
218 =head2 DeleteAttribute NAME
220 Deletes all attributes with the matching name for this object.
224 sub DeleteAttribute {
227 my ($val,$msg) = $self->Attributes->DeleteEntry( Name => $name );
228 $self->ClearAttributes;
232 =head2 FirstAttribute NAME
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.
244 return ($self->Attributes->Named( $name ))[0];
248 sub ClearAttributes {
250 delete $self->{'attributes'};
254 sub _Handle { return $RT::Handle }
258 =head2 Create PARAMHASH
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
265 If this object's table has any of the following atetributes defined as
266 'Auto', this routine will automatically fill in their values.
285 foreach my $key ( keys %attribs ) {
286 if (my $method = $self->can("Validate$key")) {
287 if (! $method->( $self, $attribs{$key} ) ) {
289 return ( 0, $self->loc('Invalid value for [_1]', $key) );
300 my ($sec,$min,$hour,$mday,$mon,$year,$wday,$ydaym,$isdst,$offset) = gmtime();
303 sprintf("%04d-%02d-%02d %02d:%02d:%02d", ($year+1900), ($mon+1), $mday, $hour, $min, $sec);
305 $attribs{'Created'} = $now_iso if ( $self->_Accessible( 'Created', 'auto' ) && !$attribs{'Created'});
307 if ($self->_Accessible( 'Creator', 'auto' ) && !$attribs{'Creator'}) {
308 $attribs{'Creator'} = $self->CurrentUser->id || '0';
310 $attribs{'LastUpdated'} = $now_iso
311 if ( $self->_Accessible( 'LastUpdated', 'auto' ) && !$attribs{'LastUpdated'});
313 $attribs{'LastUpdatedBy'} = $self->CurrentUser->id || '0'
314 if ( $self->_Accessible( 'LastUpdatedBy', 'auto' ) && !$attribs{'LastUpdatedBy'});
316 my $id = $self->SUPER::Create(%attribs);
317 if ( UNIVERSAL::isa( $id, 'Class::ReturnValue' ) ) {
321 $self->loc( "Internal Error: [_1]", $id->{error_message} ) );
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.
335 return ( $id, $self->loc('Object could not be created') );
343 if (UNIVERSAL::isa('errno',$id)) {
347 $self->Load($id) if ($id);
352 return ( $id, $self->loc('Object created') );
364 Override DBIx::SearchBuilder::LoadByCols to do case-insensitive loads if the
372 # We don't want to hang onto this
373 $self->ClearAttributes;
375 return $self->SUPER::LoadByCols( @_ ) unless $self->_Handle->CaseSensitive;
377 # If this database is case sensitive we need to uncase objects for
380 foreach my $key ( keys %hash ) {
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;
393 return $self->SUPER::LoadByCols( %hash );
398 # There is room for optimizations in most of those subs:
403 my $obj = RT::Date->new( $self->CurrentUser );
405 $obj->Set( Format => 'sql', Value => $self->LastUpdated );
413 my $obj = RT::Date->new( $self->CurrentUser );
415 $obj->Set( Format => 'sql', Value => $self->Created );
422 # TODO: This should be deprecated
426 return ( $self->CreatedObj->AgeAsString() );
431 # TODO this should be deprecated
433 sub LastUpdatedAsString {
435 if ( $self->LastUpdated ) {
436 return ( $self->LastUpdatedObj->AsString() );
446 # TODO This should be deprecated
448 sub CreatedAsString {
450 return ( $self->CreatedObj->AsString() );
455 # TODO This should be deprecated
457 sub LongSinceUpdateAsString {
459 if ( $self->LastUpdated ) {
461 return ( $self->LastUpdatedObj->AgeAsString() );
482 #if the user is trying to modify the record
483 # TODO: document _why_ this code is here
485 if ( ( !defined( $args{'Field'} ) ) || ( !defined( $args{'Value'} ) ) ) {
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'}
496 my ($status, $msg) = $ret->as_array();
498 # @values has two values, a status code and a message.
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
503 if ($self->SQLType( $args{'Field'}) =~ /text/) {
506 $self->loc( $args{'Field'} ),
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'}) . '"',
517 $msg = $self->CurrentUser->loc_fuzzy($msg);
520 return wantarray ? ($status, $msg) : $ret;
525 =head2 _SetLastUpdated
527 This routine updates the LastUpdated and LastUpdatedBy columns of the row in question
528 It takes no options. Arguably, this is a bug
532 sub _SetLastUpdated {
535 my $now = RT::Date->new( $self->CurrentUser );
538 if ( $self->_Accessible( 'LastUpdated', 'auto' ) ) {
539 my ( $msg, $val ) = $self->__Set(
540 Field => 'LastUpdated',
544 if ( $self->_Accessible( 'LastUpdatedBy', 'auto' ) ) {
545 my ( $msg, $val ) = $self->__Set(
546 Field => 'LastUpdatedBy',
547 Value => $self->CurrentUser->id
556 Returns an RT::User object with the RT account of the creator of this row
562 unless ( exists $self->{'CreatorObj'} ) {
564 $self->{'CreatorObj'} = RT::User->new( $self->CurrentUser );
565 $self->{'CreatorObj'}->Load( $self->Creator );
567 return ( $self->{'CreatorObj'} );
572 =head2 LastUpdatedByObj
574 Returns an RT::User object of the last user to touch this object
578 sub LastUpdatedByObj {
580 unless ( exists $self->{LastUpdatedByObj} ) {
581 $self->{'LastUpdatedByObj'} = RT::User->new( $self->CurrentUser );
582 $self->{'LastUpdatedByObj'}->Load( $self->LastUpdatedBy );
584 return $self->{'LastUpdatedByObj'};
591 Returns this record's URI
597 my $uri = RT::URI::fsck_com_rt->new($self->CurrentUser);
598 return($uri->URIForObject($self));
602 =head2 ValidateName NAME
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
611 if (defined $value && $value=~ /^\d+$/) {
620 =head2 SQLType attribute
622 return the SQL type for the attribute 'attribute' as stored in _ClassAccessible
630 return ($self->_Accessible($field, 'type'));
638 my %args = ( decode_utf8 => 1, @_ );
641 $RT::Logger->error("__Value called with undef field");
644 my $value = $self->SUPER::__Value($field);
646 return undef if (!defined $value);
648 # Pg returns character columns as character strings; mysql and
649 # sqlite return them as bytes. While mysql can be made to return
650 # characters, using the mysql_enable_utf8 flag, the "Content" column
651 # is bytes on mysql and characters on Postgres, making true
652 # consistency impossible.
653 if ( $args{'decode_utf8'} ) {
654 if ( !utf8::is_utf8($value) ) { # mysql/sqlite
655 utf8::decode($value);
658 if ( utf8::is_utf8($value) ) {
659 utf8::encode($value);
667 # Set up defaults for DBIx::SearchBuilder::Record::Cachable
671 'cache_for_sec' => 30,
677 sub _BuildTableAttributes {
679 my $class = ref($self) || $self;
682 if ( UNIVERSAL::can( $self, '_CoreAccessible' ) ) {
683 $attributes = $self->_CoreAccessible();
684 } elsif ( UNIVERSAL::can( $self, '_ClassAccessible' ) ) {
685 $attributes = $self->_ClassAccessible();
689 foreach my $column (keys %$attributes) {
690 foreach my $attr ( keys %{ $attributes->{$column} } ) {
691 $_TABLE_ATTR->{$class}->{$column}->{$attr} = $attributes->{$column}->{$attr};
694 foreach my $method ( qw(_OverlayAccessible _VendorAccessible _LocalAccessible) ) {
695 next unless UNIVERSAL::can( $self, $method );
696 $attributes = $self->$method();
698 foreach my $column ( keys %$attributes ) {
699 foreach my $attr ( keys %{ $attributes->{$column} } ) {
700 $_TABLE_ATTR->{$class}->{$column}->{$attr} = $attributes->{$column}->{$attr};
707 =head2 _ClassAccessible
709 Overrides the "core" _ClassAccessible using $_TABLE_ATTR. Behaves identical to the version in
710 DBIx::SearchBuilder::Record
714 sub _ClassAccessible {
716 return $_TABLE_ATTR->{ref($self) || $self};
719 =head2 _Accessible COLUMN ATTRIBUTE
721 returns the value of ATTRIBUTE for COLUMN
729 my $attribute = lc(shift);
730 return 0 unless defined ($_TABLE_ATTR->{ref($self)}->{$column});
731 return $_TABLE_ATTR->{ref($self)}->{$column}->{$attribute} || 0;
735 =head2 _EncodeLOB BODY MIME_TYPE FILENAME
737 Takes a potentially large attachment. Returns (ContentEncoding,
738 EncodedBody, MimeType, Filename) based on system configuration and
739 selected database. Returns a custom (short) text/plain message if
740 DropLongAttachments causes an attachment to not be stored.
742 Encodes your data as base64 or Quoted-Printable as needed based on your
743 Databases's restrictions and the UTF-8ness of the data being passed in. Since
744 we are storing in columns marked UTF8, we must ensure that binary data is
745 encoded on databases which are strict.
747 This function expects to receive an octet string in order to properly
748 evaluate and encode it. It will return an octet string.
755 my $MIMEType = shift || '';
756 my $Filename = shift;
758 my $ContentEncoding = 'none';
760 RT::Util::assert_bytes( $Body );
762 #get the max attachment length from RT
763 my $MaxSize = RT->Config->Get('MaxAttachmentSize');
765 #if the current attachment contains nulls and the
766 #database doesn't support embedded nulls
768 if ( ( !$RT::Handle->BinarySafeBLOBs ) && ( $Body =~ /\x00/ ) ) {
770 # set a flag telling us to mimencode the attachment
771 $ContentEncoding = 'base64';
773 #cut the max attchment size by 25% (for mime-encoding overhead.
774 $RT::Logger->debug("Max size is $MaxSize");
775 $MaxSize = $MaxSize * 3 / 4;
776 # Some databases (postgres) can't handle non-utf8 data
777 } elsif ( !$RT::Handle->BinarySafeBLOBs
778 && $Body =~ /\P{ASCII}/
779 && !Encode::is_utf8( $Body, 1 ) ) {
780 $ContentEncoding = 'quoted-printable';
783 #if the attachment is larger than the maximum size
784 if ( ($MaxSize) and ( $MaxSize < length($Body) ) ) {
786 # if we're supposed to truncate large attachments
787 if (RT->Config->Get('TruncateLongAttachments')) {
789 # truncate the attachment to that length.
790 $Body = substr( $Body, 0, $MaxSize );
794 # elsif we're supposed to drop large attachments on the floor,
795 elsif (RT->Config->Get('DropLongAttachments')) {
797 # drop the attachment on the floor
798 $RT::Logger->info( "$self: Dropped an attachment of size "
800 $RT::Logger->info( "It started: " . substr( $Body, 0, 60 ) );
801 $Filename .= ".txt" if $Filename;
802 return ("none", "Large attachment dropped", "text/plain", $Filename );
806 # if we need to mimencode the attachment
807 if ( $ContentEncoding eq 'base64' ) {
808 # base64 encode the attachment
809 $Body = MIME::Base64::encode_base64($Body);
811 } elsif ($ContentEncoding eq 'quoted-printable') {
812 $Body = MIME::QuotedPrint::encode($Body);
815 return ($ContentEncoding, $Body, $MIMEType, $Filename );
818 =head2 _DecodeLOB C<ContentType>, C<ContentEncoding>, C<Content>
820 Unpacks data stored in the database, which may be base64 or QP encoded
821 because of our need to store binary and badly encoded data in columns
822 marked as UTF-8. Databases such as PostgreSQL and Oracle care that you
823 are feeding them invalid UTF-8 and will refuse the content. This
824 function handles unpacking the encoded data.
826 It returns textual data as a UTF-8 string which has been processed by Encode's
827 PERLQQ filter which will replace the invalid bytes with \x{HH} so you can see
828 the invalid byte but won't run into problems treating the data as UTF-8 later.
830 This is similar to how we filter all data coming in via the web UI in
831 RT::Interface::Web::DecodeARGS. This filter should only end up being
832 applied to old data from less UTF-8-safe versions of RT.
834 If the passed C<ContentType> includes a character set, that will be used
835 to decode textual data; the default character set is UTF-8. This is
836 necessary because while we attempt to store textual data as UTF-8, the
837 definition of "textual" has migrated over time, and thus we may now need
838 to attempt to decode data that was previously not trancoded on insertion.
840 Important Note - This function expects an octet string and returns a
841 character string for non-binary data.
847 my $ContentType = shift || '';
848 my $ContentEncoding = shift || 'none';
851 RT::Util::assert_bytes( $Content );
853 if ( $ContentEncoding eq 'base64' ) {
854 $Content = MIME::Base64::decode_base64($Content);
856 elsif ( $ContentEncoding eq 'quoted-printable' ) {
857 $Content = MIME::QuotedPrint::decode($Content);
859 elsif ( $ContentEncoding && $ContentEncoding ne 'none' ) {
860 return ( $self->loc( "Unknown ContentEncoding [_1]", $ContentEncoding ) );
862 if ( RT::I18N::IsTextualContentType($ContentType) ) {
863 my $entity = MIME::Entity->new();
864 $entity->head->add("Content-Type", $ContentType);
865 $entity->bodyhandle( MIME::Body::Scalar->new( $Content ) );
866 my $charset = RT::I18N::_FindOrGuessCharset($entity);
867 $charset = 'utf-8' if not $charset or not Encode::find_encoding($charset);
869 $Content = Encode::decode($charset,$Content,Encode::FB_PERLQQ);
874 # A helper table for links mapping to make it easier
875 # to build and parse links between tickets
877 use vars '%LINKDIRMAP';
880 MemberOf => { Base => 'MemberOf',
881 Target => 'HasMember', },
882 RefersTo => { Base => 'RefersTo',
883 Target => 'ReferredToBy', },
884 DependsOn => { Base => 'DependsOn',
885 Target => 'DependedOnBy', },
886 MergedInto => { Base => 'MergedInto',
887 Target => 'MergedInto', },
891 =head2 Update ARGSHASH
893 Updates fields on an object for you using the proper Set methods,
894 skipping unchanged values.
896 ARGSRef => a hashref of attributes => value for the update
897 AttributesRef => an arrayref of keys in ARGSRef that should be updated
898 AttributePrefix => a prefix that should be added to the attributes in AttributesRef
899 when looking up values in ARGSRef
900 Bare attributes are tried before prefixed attributes
902 Returns a list of localized results of the update
911 AttributesRef => undef,
912 AttributePrefix => undef,
916 my $attributes = $args{'AttributesRef'};
917 my $ARGSRef = $args{'ARGSRef'};
920 # gather all new values
921 foreach my $attribute (@$attributes) {
923 if ( defined $ARGSRef->{$attribute} ) {
924 $value = $ARGSRef->{$attribute};
927 defined( $args{'AttributePrefix'} )
929 $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute }
932 $value = $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute };
939 $value =~ s/\r\n/\n/gs;
941 my $truncated_value = $self->TruncateValue($attribute, $value);
943 # If Queue is 'General', we want to resolve the queue name for
946 # This is in an eval block because $object might not exist.
947 # and might not have a Name method. But "can" won't find autoloaded
948 # items. If it fails, we don't care
950 no warnings "uninitialized";
953 my $object = $attribute . "Obj";
954 my $name = $self->$object->Name;
955 next if $name eq $value || $name eq ($value || 0);
958 my $current = $self->$attribute();
959 # RT::Queue->Lifecycle returns a Lifecycle object instead of name
960 $current = eval { $current->Name } if ref $current;
961 next if $truncated_value eq $current;
962 next if ( $truncated_value || 0 ) eq $current;
965 $new_values{$attribute} = $value;
968 return $self->_UpdateAttributes(
969 Attributes => $attributes,
970 NewValues => \%new_values,
974 sub _UpdateAttributes {
984 foreach my $attribute (@{ $args{Attributes} }) {
985 next if !exists($args{NewValues}{$attribute});
987 my $value = $args{NewValues}{$attribute};
988 my $method = "Set$attribute";
989 my ( $code, $msg ) = $self->$method($value);
990 my ($prefix) = ref($self) =~ /RT(?:.*)::(\w+)/;
992 # Default to $id, but use name if we can get it.
993 my $label = $self->id;
994 $label = $self->Name if (UNIVERSAL::can($self,'Name'));
995 # this requires model names to be loc'ed.
1006 push @results, $self->loc( $prefix ) . " $label: ". $msg;
1010 "[_1] could not be set to [_2].", # loc
1011 "That is already the current value", # loc
1012 "No value sent to _Set!", # loc
1013 "Illegal value for [_1]", # loc
1014 "The new value has been set.", # loc
1015 "No column specified", # loc
1016 "Immutable field", # loc
1017 "Nonexistant field?", # loc
1018 "Invalid data", # loc
1019 "Couldn't find row", # loc
1020 "Missing a primary key?: [_1]", # loc
1021 "Found Object", # loc
1035 This returns an RT::Links object which references all the tickets
1036 which are 'MembersOf' this ticket
1042 return ( $self->_Links( 'Target', 'MemberOf' ) );
1049 This returns an RT::Links object which references all the tickets that this
1050 ticket is a 'MemberOf'
1056 return ( $self->_Links( 'Base', 'MemberOf' ) );
1063 This returns an RT::Links object which shows all references for which this ticket is a base
1069 return ( $self->_Links( 'Base', 'RefersTo' ) );
1076 This returns an L<RT::Links> object which shows all references for which this ticket is a target
1082 return ( $self->_Links( 'Target', 'RefersTo' ) );
1089 This returns an RT::Links object which references all the tickets that depend on this one
1095 return ( $self->_Links( 'Target', 'DependsOn' ) );
1101 =head2 HasUnresolvedDependencies
1103 Takes a paramhash of Type (default to '__any'). Returns the number of
1104 unresolved dependencies, if $self->UnresolvedDependencies returns an
1105 object with one or more members of that type. Returns false
1110 sub HasUnresolvedDependencies {
1117 my $deps = $self->UnresolvedDependencies;
1120 $deps->Limit( FIELD => 'Type',
1122 VALUE => $args{Type});
1128 if ($deps->Count > 0) {
1129 return $deps->Count;
1138 =head2 UnresolvedDependencies
1140 Returns an RT::Tickets object of tickets which this ticket depends on
1141 and which have a status of new, open or stalled. (That list comes from
1142 RT::Queue->ActiveStatusArray
1147 sub UnresolvedDependencies {
1149 my $deps = RT::Tickets->new($self->CurrentUser);
1151 my @live_statuses = RT::Queue->ActiveStatusArray();
1152 foreach my $status (@live_statuses) {
1153 $deps->LimitStatus(VALUE => $status);
1155 $deps->LimitDependedOnBy($self->Id);
1163 =head2 AllDependedOnBy
1165 Returns an array of RT::Ticket objects which (directly or indirectly)
1166 depends on this ticket; takes an optional 'Type' argument in the param
1167 hash, which will limit returned tickets to that type, as well as cause
1168 tickets with that type to serve as 'leaf' nodes that stops the recursive
1173 sub AllDependedOnBy {
1175 return $self->_AllLinkedTickets( LinkType => 'DependsOn',
1176 Direction => 'Target', @_ );
1181 Returns an array of RT::Ticket objects which this ticket (directly or
1182 indirectly) depends on; takes an optional 'Type' argument in the param
1183 hash, which will limit returned tickets to that type, as well as cause
1184 tickets with that type to serve as 'leaf' nodes that stops the
1185 recursive dependency search.
1191 return $self->_AllLinkedTickets( LinkType => 'DependsOn',
1192 Direction => 'Base', @_ );
1195 sub _AllLinkedTickets {
1207 my $dep = $self->_Links( $args{Direction}, $args{LinkType});
1208 while (my $link = $dep->Next()) {
1209 my $uri = $args{Direction} eq 'Target' ? $link->BaseURI : $link->TargetURI;
1210 next unless ($uri->IsLocal());
1211 my $obj = $args{Direction} eq 'Target' ? $link->BaseObj : $link->TargetObj;
1212 next if $args{_found}{$obj->Id};
1215 $args{_found}{$obj->Id} = $obj;
1216 $obj->_AllLinkedTickets( %args, _top => 0 );
1218 elsif ($obj->Type and $obj->Type eq $args{Type}) {
1219 $args{_found}{$obj->Id} = $obj;
1222 $obj->_AllLinkedTickets( %args, _top => 0 );
1227 return map { $args{_found}{$_} } sort keys %{$args{_found}};
1238 This returns an RT::Links object which references all the tickets that this ticket depends on
1244 return ( $self->_Links( 'Base', 'DependsOn' ) );
1253 This returns an RT::Links object which references all the customers that
1254 this object is a member of. This includes both explicitly linked customers
1255 and links implied by services.
1260 my( $self, %opt ) = @_;
1261 my $Debug = $opt{'Debug'};
1263 unless ( $self->{'Customers'} ) {
1265 $self->{'Customers'} = $self->MemberOf->Clone;
1267 for my $fstable (qw(cust_main cust_svc)) {
1269 $self->{'Customers'}->Limit(
1271 OPERATOR => 'STARTSWITH',
1272 VALUE => "freeside://freeside/$fstable",
1273 ENTRYAGGREGATOR => 'OR',
1274 SUBCLAUSE => 'customers',
1279 warn "->Customers method called on $self; returning ".
1280 ref($self->{'Customers'}). ' object'
1283 return $self->{'Customers'};
1292 This returns an RT::Links object which references all the services this
1293 object is a member of.
1298 my( $self, %opt ) = @_;
1300 unless ( $self->{'Services'} ) {
1302 $self->{'Services'} = $self->MemberOf->Clone;
1304 $self->{'Services'}->Limit(
1306 OPERATOR => 'STARTSWITH',
1307 VALUE => "freeside://freeside/cust_svc",
1311 return $self->{'Services'};
1319 =head2 Links DIRECTION [TYPE]
1321 Return links (L<RT::Links>) to/from this object.
1323 DIRECTION is either 'Base' or 'Target'.
1325 TYPE is a type of links to return, it can be omitted to get
1330 sub Links { shift->_Links(@_) }
1335 #TODO: Field isn't the right thing here. but I ahave no idea what mnemonic ---
1338 my $type = shift || "";
1340 unless ( $self->{"$field$type"} ) {
1341 $self->{"$field$type"} = RT::Links->new( $self->CurrentUser );
1342 # at least to myself
1343 $self->{"$field$type"}->Limit( FIELD => $field,
1344 VALUE => $self->URI,
1345 ENTRYAGGREGATOR => 'OR' );
1346 $self->{"$field$type"}->Limit( FIELD => 'Type',
1350 return ( $self->{"$field$type"} );
1358 Takes a Type and returns a string that is more human readable.
1364 my %args = ( Type => '',
1367 $args{Type} =~ s/([A-Z])/" " . lc $1/ge;
1368 $args{Type} =~ s/^\s+//;
1377 Takes either a Target or a Base and returns a string of human friendly text.
1383 my %args = ( Object => undef,
1387 my $text = "URI " . $args{FallBack};
1388 if ($args{Object} && $args{Object}->isa("RT::Ticket")) {
1389 $text = "Ticket " . $args{Object}->id;
1398 Takes a paramhash of Type and one of Base or Target. Adds that link to this object.
1400 Returns C<link id>, C<message> and C<exist> flag.
1407 my %args = ( Target => '',
1414 # Remote_link is the URI of the object that is not this ticket
1418 if ( $args{'Base'} and $args{'Target'} ) {
1419 $RT::Logger->debug( "$self tried to create a link. both base and target were specified" );
1420 return ( 0, $self->loc("Can't specify both base and target") );
1422 elsif ( $args{'Base'} ) {
1423 $args{'Target'} = $self->URI();
1424 $remote_link = $args{'Base'};
1425 $direction = 'Target';
1427 elsif ( $args{'Target'} ) {
1428 $args{'Base'} = $self->URI();
1429 $remote_link = $args{'Target'};
1430 $direction = 'Base';
1433 return ( 0, $self->loc('Either base or target must be specified') );
1436 # Check if the link already exists - we don't want duplicates
1438 my $old_link = RT::Link->new( $self->CurrentUser );
1439 $old_link->LoadByParams( Base => $args{'Base'},
1440 Type => $args{'Type'},
1441 Target => $args{'Target'} );
1442 if ( $old_link->Id ) {
1443 $RT::Logger->debug("$self Somebody tried to duplicate a link");
1444 return ( $old_link->id, $self->loc("Link already exists"), 1 );
1450 # Storing the link in the DB.
1451 my $link = RT::Link->new( $self->CurrentUser );
1452 my ($linkid, $linkmsg) = $link->Create( Target => $args{Target},
1453 Base => $args{Base},
1454 Type => $args{Type} );
1457 $RT::Logger->error("Link could not be created: ".$linkmsg);
1458 return ( 0, $self->loc("Link could not be created") );
1461 my $basetext = $self->FormatLink(Object => $link->BaseObj,
1462 FallBack => $args{Base});
1463 my $targettext = $self->FormatLink(Object => $link->TargetObj,
1464 FallBack => $args{Target});
1465 my $typetext = $self->FormatType(Type => $args{Type});
1467 "$basetext $typetext $targettext.";
1468 return ( $linkid, $TransString ) ;
1475 Delete a link. takes a paramhash of Base, Target and Type.
1476 Either Base or Target must be null. The null value will
1477 be replaced with this ticket's id
1490 #we want one of base and target. we don't care which
1491 #but we only want _one_
1496 if ( $args{'Base'} and $args{'Target'} ) {
1497 $RT::Logger->debug("$self ->_DeleteLink. got both Base and Target");
1498 return ( 0, $self->loc("Can't specify both base and target") );
1500 elsif ( $args{'Base'} ) {
1501 $args{'Target'} = $self->URI();
1502 $remote_link = $args{'Base'};
1503 $direction = 'Target';
1505 elsif ( $args{'Target'} ) {
1506 $args{'Base'} = $self->URI();
1507 $remote_link = $args{'Target'};
1511 $RT::Logger->error("Base or Target must be specified");
1512 return ( 0, $self->loc('Either base or target must be specified') );
1515 my $link = RT::Link->new( $self->CurrentUser );
1516 $RT::Logger->debug( "Trying to load link: " . $args{'Base'} . " " . $args{'Type'} . " " . $args{'Target'} );
1519 $link->LoadByParams( Base=> $args{'Base'}, Type=> $args{'Type'}, Target=> $args{'Target'} );
1523 my $basetext = $self->FormatLink(Object => $link->BaseObj,
1524 FallBack => $args{Base});
1525 my $targettext = $self->FormatLink(Object => $link->TargetObj,
1526 FallBack => $args{Target});
1527 my $typetext = $self->FormatType(Type => $args{Type});
1528 my $linkid = $link->id;
1530 my $TransString = "$basetext no longer $typetext $targettext.";
1531 return ( 1, $TransString);
1534 #if it's not a link we can find
1536 $RT::Logger->debug("Couldn't find that link");
1537 return ( 0, $self->loc("Link not found") );
1542 =head1 LockForUpdate
1544 In a database transaction, gains an exclusive lock on the row, to
1545 prevent race conditions. On SQLite, this is a "RESERVED" lock on the
1553 my $pk = $self->_PrimaryKey;
1554 my $id = @_ ? $_[0] : $self->$pk;
1555 $self->_expire if $self->isa("DBIx::SearchBuilder::Record::Cachable");
1556 if (RT->Config->Get('DatabaseType') eq "SQLite") {
1557 # SQLite does DB-level locking, upgrading the transaction to
1558 # "RESERVED" on the first UPDATE/INSERT/DELETE. Do a no-op
1559 # UPDATE to force the upgade.
1560 return RT->DatabaseHandle->dbh->do(
1561 "UPDATE " .$self->Table.
1562 " SET $pk = $pk WHERE 1 = 0");
1564 return $self->_LoadFromSQL(
1565 "SELECT * FROM ".$self->Table
1566 ." WHERE $pk = ? FOR UPDATE",
1572 =head2 _NewTransaction PARAMHASH
1574 Private function to create a new RT::Transaction object for this ticket update
1578 sub _NewTransaction {
1585 OldReference => undef,
1586 NewReference => undef,
1587 ReferenceType => undef,
1591 ActivateScrips => 1,
1593 SquelchMailTo => undef,
1598 my $in_txn = RT->DatabaseHandle->TransactionDepth;
1599 RT->DatabaseHandle->BeginTransaction unless $in_txn;
1601 $self->LockForUpdate;
1603 my $old_ref = $args{'OldReference'};
1604 my $new_ref = $args{'NewReference'};
1605 my $ref_type = $args{'ReferenceType'};
1606 if ($old_ref or $new_ref) {
1607 $ref_type ||= ref($old_ref) || ref($new_ref);
1609 $RT::Logger->error("Reference type not specified for transaction");
1612 $old_ref = $old_ref->Id if ref($old_ref);
1613 $new_ref = $new_ref->Id if ref($new_ref);
1616 require RT::Transaction;
1617 my $trans = RT::Transaction->new( $self->CurrentUser );
1618 my ( $transaction, $msg ) = $trans->Create(
1619 ObjectId => $self->Id,
1620 ObjectType => ref($self),
1621 TimeTaken => $args{'TimeTaken'},
1622 Type => $args{'Type'},
1623 Data => $args{'Data'},
1624 Field => $args{'Field'},
1625 NewValue => $args{'NewValue'},
1626 OldValue => $args{'OldValue'},
1627 NewReference => $new_ref,
1628 OldReference => $old_ref,
1629 ReferenceType => $ref_type,
1630 MIMEObj => $args{'MIMEObj'},
1631 ActivateScrips => $args{'ActivateScrips'},
1632 CommitScrips => $args{'CommitScrips'},
1633 SquelchMailTo => $args{'SquelchMailTo'},
1634 CustomFields => $args{'CustomFields'},
1637 # Rationalize the object since we may have done things to it during the caching.
1638 $self->Load($self->Id);
1640 $RT::Logger->warning($msg) unless $transaction;
1642 $self->_SetLastUpdated;
1644 if ( defined $args{'TimeTaken'} and $self->can('_UpdateTimeTaken')) {
1645 $self->_UpdateTimeTaken( $args{'TimeTaken'} );
1647 if ( RT->Config->Get('UseTransactionBatch') and $transaction ) {
1648 push @{$self->{_TransactionBatch}}, $trans if $args{'CommitScrips'};
1651 RT->DatabaseHandle->Commit unless $in_txn;
1653 return ( $transaction, $msg, $trans );
1660 Returns an RT::Transactions object of all transactions on this record object
1667 use RT::Transactions;
1668 my $transactions = RT::Transactions->new( $self->CurrentUser );
1670 #If the user has no rights, return an empty object
1671 $transactions->Limit(
1672 FIELD => 'ObjectId',
1675 $transactions->Limit(
1676 FIELD => 'ObjectType',
1677 VALUE => ref($self),
1680 return ($transactions);
1687 my $cfs = RT::CustomFields->new( $self->CurrentUser );
1689 $cfs->SetContextObject( $self );
1690 # XXX handle multiple types properly
1691 $cfs->LimitToLookupType( $self->CustomFieldLookupType );
1692 $cfs->LimitToGlobalOrObjectId( $self->CustomFieldLookupId );
1693 $cfs->ApplySortOrder;
1698 # TODO: This _only_ works for RT::Foo classes. it doesn't work, for
1699 # example, for RT::IR::Foo classes.
1701 sub CustomFieldLookupId {
1703 my $lookup = shift || $self->CustomFieldLookupType;
1704 my @classes = ($lookup =~ /RT::(\w+)-/g);
1706 # Work on "RT::Queue", for instance
1707 return $self->Id unless @classes;
1710 # Save a ->Load call by not calling ->FooObj->Id, just ->Foo
1711 my $final = shift @classes;
1712 foreach my $class (reverse @classes) {
1713 my $method = "${class}Obj";
1714 $object = $object->$method;
1717 my $id = $object->$final;
1718 unless (defined $id) {
1719 my $method = "${final}Obj";
1720 $id = $object->$method->Id;
1726 =head2 CustomFieldLookupType
1728 Returns the path RT uses to figure out which custom fields apply to this object.
1732 sub CustomFieldLookupType {
1734 return ref($self) || $self;
1738 =head2 AddCustomFieldValue { Field => FIELD, Value => VALUE }
1740 VALUE should be a string. FIELD can be any identifier of a CustomField
1741 supported by L</LoadCustomFieldByIdentifier> method.
1743 Adds VALUE as a value of CustomField FIELD. If this is a single-value custom field,
1744 deletes the old value.
1745 If VALUE is not a valid value for the custom field, returns
1746 (0, 'Error message' ) otherwise, returns ($id, 'Success Message') where
1747 $id is ID of created L<ObjectCustomFieldValue> object.
1751 sub AddCustomFieldValue {
1753 $self->_AddCustomFieldValue(@_);
1756 sub _AddCustomFieldValue {
1761 LargeContent => undef,
1762 ContentType => undef,
1763 RecordTransaction => 1,
1767 my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
1768 unless ( $cf->Id ) {
1769 return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
1772 my $OCFs = $self->CustomFields;
1773 $OCFs->Limit( FIELD => 'id', VALUE => $cf->Id );
1774 unless ( $OCFs->Count ) {
1778 "Custom field [_1] does not apply to this object",
1779 ref $args{'Field'} ? $args{'Field'}->id : $args{'Field'}
1784 # empty string is not correct value of any CF, so undef it
1785 foreach ( qw(Value LargeContent) ) {
1786 $args{ $_ } = undef if defined $args{ $_ } && !length $args{ $_ };
1789 unless ( $cf->ValidateValue( $args{'Value'} ) ) {
1790 return ( 0, $self->loc("Invalid value for custom field") );
1793 # If the custom field only accepts a certain # of values, delete the existing
1794 # value and record a "changed from foo to bar" transaction
1795 unless ( $cf->UnlimitedValues ) {
1797 # Load up a ObjectCustomFieldValues object for this custom field and this ticket
1798 my $values = $cf->ValuesForObject($self);
1800 # We need to whack any old values here. In most cases, the custom field should
1801 # only have one value to delete. In the pathalogical case, this custom field
1802 # used to be a multiple and we have many values to whack....
1803 my $cf_values = $values->Count;
1805 if ( $cf_values > $cf->MaxValues ) {
1806 my $i = 0; #We want to delete all but the max we can currently have , so we can then
1807 # execute the same code to "change" the value from old to new
1808 while ( my $value = $values->Next ) {
1810 if ( $i < $cf_values ) {
1811 my ( $val, $msg ) = $cf->DeleteValueForObject(
1818 my ( $TransactionId, $Msg, $TransactionObj ) =
1819 $self->_NewTransaction(
1820 Type => 'CustomField',
1822 OldReference => $value,
1826 $values->RedoSearch if $i; # redo search if have deleted at least one value
1829 if ( my $entry = $values->HasEntry($args{'Value'}, $args{'LargeContent'}) ) {
1833 my $old_value = $values->First;
1835 $old_content = $old_value->Content if $old_value;
1837 my ( $new_value_id, $value_msg ) = $cf->AddValueForObject(
1839 Content => $args{'Value'},
1840 LargeContent => $args{'LargeContent'},
1841 ContentType => $args{'ContentType'},
1844 unless ( $new_value_id ) {
1845 return ( 0, $self->loc( "Could not add new custom field value: [_1]", $value_msg ) );
1848 my $new_value = RT::ObjectCustomFieldValue->new( $self->CurrentUser );
1849 $new_value->Load( $new_value_id );
1851 # now that adding the new value was successful, delete the old one
1853 my ( $val, $msg ) = $old_value->Delete();
1854 return ( 0, $msg ) unless $val;
1857 if ( $args{'RecordTransaction'} ) {
1858 my ( $TransactionId, $Msg, $TransactionObj ) =
1859 $self->_NewTransaction(
1860 Type => 'CustomField',
1862 OldReference => $old_value,
1863 NewReference => $new_value,
1867 my $new_content = $new_value->Content;
1869 # For datetime, we need to display them in "human" format in result message
1870 #XXX TODO how about date without time?
1871 if ($cf->Type eq 'DateTime') {
1872 my $DateObj = RT::Date->new( $self->CurrentUser );
1875 Value => $new_content,
1877 $new_content = $DateObj->AsString;
1879 if ( defined $old_content && length $old_content ) {
1882 Value => $old_content,
1884 $old_content = $DateObj->AsString;
1888 unless ( defined $old_content && length $old_content ) {
1889 return ( $new_value_id, $self->loc( "[_1] [_2] added", $cf->Name, $new_content ));
1891 elsif ( !defined $new_content || !length $new_content ) {
1892 return ( $new_value_id,
1893 $self->loc( "[_1] [_2] deleted", $cf->Name, $old_content ) );
1896 return ( $new_value_id, $self->loc( "[_1] [_2] changed to [_3]", $cf->Name, $old_content, $new_content));
1901 # otherwise, just add a new value and record "new value added"
1903 if ( !$cf->Repeated ) {
1904 my $values = $cf->ValuesForObject($self);
1905 if ( my $entry = $values->HasEntry($args{'Value'}, $args{'LargeContent'}) ) {
1910 my ($new_value_id, $msg) = $cf->AddValueForObject(
1912 Content => $args{'Value'},
1913 LargeContent => $args{'LargeContent'},
1914 ContentType => $args{'ContentType'},
1917 unless ( $new_value_id ) {
1918 return ( 0, $self->loc( "Could not add new custom field value: [_1]", $msg ) );
1920 if ( $args{'RecordTransaction'} ) {
1921 my ( $tid, $msg ) = $self->_NewTransaction(
1922 Type => 'CustomField',
1924 NewReference => $new_value_id,
1925 ReferenceType => 'RT::ObjectCustomFieldValue',
1928 return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $msg ) );
1931 return ( $new_value_id, $self->loc( "[_1] added as a value for [_2]", $args{'Value'}, $cf->Name ) );
1937 =head2 DeleteCustomFieldValue { Field => FIELD, Value => VALUE }
1939 Deletes VALUE as a value of CustomField FIELD.
1941 VALUE can be a string, a CustomFieldValue or a ObjectCustomFieldValue.
1943 If VALUE is not a valid value for the custom field, returns
1944 (0, 'Error message' ) otherwise, returns (1, 'Success Message')
1948 sub DeleteCustomFieldValue {
1957 my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
1958 unless ( $cf->Id ) {
1959 return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
1962 my ( $val, $msg ) = $cf->DeleteValueForObject(
1964 Id => $args{'ValueId'},
1965 Content => $args{'Value'},
1971 my ( $TransactionId, $Msg, $TransactionObj ) = $self->_NewTransaction(
1972 Type => 'CustomField',
1974 OldReference => $val,
1975 ReferenceType => 'RT::ObjectCustomFieldValue',
1977 unless ($TransactionId) {
1978 return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $Msg ) );
1981 my $old_value = $TransactionObj->OldValue;
1982 # For datetime, we need to display them in "human" format in result message
1983 if ( $cf->Type eq 'DateTime' ) {
1984 my $DateObj = RT::Date->new( $self->CurrentUser );
1987 Value => $old_value,
1989 $old_value = $DateObj->AsString;
1994 "[_1] is no longer a value for custom field [_2]",
1995 $old_value, $cf->Name
2002 =head2 FirstCustomFieldValue FIELD
2004 Return the content of the first value of CustomField FIELD for this ticket
2005 Takes a field id or name
2009 sub FirstCustomFieldValue {
2013 my $values = $self->CustomFieldValues( $field );
2014 return undef unless my $first = $values->First;
2015 return $first->Content;
2018 =head2 CustomFieldValuesAsString FIELD
2020 Return the content of the CustomField FIELD for this ticket.
2021 If this is a multi-value custom field, values will be joined with newlines.
2023 Takes a field id or name as the first argument
2025 Takes an optional Separator => "," second and third argument
2026 if you want to join the values using something other than a newline
2030 sub CustomFieldValuesAsString {
2034 my $separator = $args{Separator} || "\n";
2036 my $values = $self->CustomFieldValues( $field );
2037 return join ($separator, grep { defined $_ }
2038 map { $_->Content } @{$values->ItemsArrayRef});
2043 =head2 CustomFieldValues FIELD
2045 Return a ObjectCustomFieldValues object of all values of the CustomField whose
2046 id or Name is FIELD for this record.
2048 Returns an RT::ObjectCustomFieldValues object
2052 sub CustomFieldValues {
2057 my $cf = $self->LoadCustomFieldByIdentifier( $field );
2059 # we were asked to search on a custom field we couldn't find
2060 unless ( $cf->id ) {
2061 $RT::Logger->warning("Couldn't load custom field by '$field' identifier");
2062 return RT::ObjectCustomFieldValues->new( $self->CurrentUser );
2064 return ( $cf->ValuesForObject($self) );
2067 # we're not limiting to a specific custom field;
2068 my $ocfs = RT::ObjectCustomFieldValues->new( $self->CurrentUser );
2069 $ocfs->LimitToObject( $self );
2073 =head2 LoadCustomFieldByIdentifier IDENTIFER
2075 Find the custom field has id or name IDENTIFIER for this object.
2077 If no valid field is found, returns an empty RT::CustomField object.
2081 sub LoadCustomFieldByIdentifier {
2086 if ( UNIVERSAL::isa( $field, "RT::CustomField" ) ) {
2087 $cf = RT::CustomField->new($self->CurrentUser);
2088 $cf->SetContextObject( $self );
2089 $cf->LoadById( $field->id );
2091 elsif ($field =~ /^\d+$/) {
2092 $cf = RT::CustomField->new($self->CurrentUser);
2093 $cf->SetContextObject( $self );
2094 $cf->LoadById($field);
2097 my $cfs = $self->CustomFields($self->CurrentUser);
2098 $cfs->SetContextObject( $self );
2099 $cfs->Limit(FIELD => 'Name', VALUE => $field, CASESENSITIVE => 0);
2100 $cf = $cfs->First || RT::CustomField->new($self->CurrentUser);
2105 sub ACLEquivalenceObjects { }
2107 sub BasicColumns { }
2110 return RT->Config->Get('WebPath'). "/index.html?q=";
2113 RT::Base->_ImportOverlays();