1 # BEGIN BPS TAGGED BLOCK {{{
5 # This software is Copyright (c) 1996-2014 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
76 our $_TABLE_ATTR = { };
77 use base RT->Config->Get('RecordBaseClass');
83 $self->_BuildTableAttributes unless ($_TABLE_ATTR->{ref($self)});
84 $self->CurrentUser(@_);
91 The primary keys for RT classes is 'id'
95 sub _PrimaryKeys { return ['id'] }
96 # short circuit many, many thousands of calls from searchbuilder
97 sub _PrimaryKey { 'id' }
101 Override L<DBIx::SearchBuilder/Id> to avoid a few lookups RT doesn't do
102 on a very common codepath
104 C<id> is an alias to C<Id> and is the preferred way to call this method.
109 return shift->{'values'}->{id};
116 Delete this record object from the database.
122 my ($rv) = $self->SUPER::Delete;
124 return ($rv, $self->loc("Object deleted"));
127 return(0, $self->loc("Object could not be deleted"))
133 Returns a string which is this object's type. The type is the class,
134 without the "RT::" prefix.
141 if (ref($self) =~ /^.*::(\w+)$/) {
142 return $self->loc($1);
144 return $self->loc(ref($self));
150 Return this object's attributes as an RT::Attributes object
156 unless ($self->{'attributes'}) {
157 $self->{'attributes'} = RT::Attributes->new($self->CurrentUser);
158 $self->{'attributes'}->LimitToObject($self);
159 $self->{'attributes'}->OrderByCols({FIELD => 'id'});
161 return ($self->{'attributes'});
165 =head2 AddAttribute { Name, Description, Content }
167 Adds a new attribute for this object.
173 my %args = ( Name => undef,
174 Description => undef,
178 my $attr = RT::Attribute->new( $self->CurrentUser );
179 my ( $id, $msg ) = $attr->Create(
181 Name => $args{'Name'},
182 Description => $args{'Description'},
183 Content => $args{'Content'} );
186 # XXX TODO: Why won't RedoSearch work here?
187 $self->Attributes->_DoSearch;
193 =head2 SetAttribute { Name, Description, Content }
195 Like AddAttribute, but replaces all existing attributes with the same Name.
201 my %args = ( Name => undef,
202 Description => undef,
206 my @AttributeObjs = $self->Attributes->Named( $args{'Name'} )
207 or return $self->AddAttribute( %args );
209 my $AttributeObj = pop( @AttributeObjs );
210 $_->Delete foreach @AttributeObjs;
212 $AttributeObj->SetDescription( $args{'Description'} );
213 $AttributeObj->SetContent( $args{'Content'} );
215 $self->Attributes->RedoSearch;
219 =head2 DeleteAttribute NAME
221 Deletes all attributes with the matching name for this object.
225 sub DeleteAttribute {
228 my ($val,$msg) = $self->Attributes->DeleteEntry( Name => $name );
229 $self->ClearAttributes;
233 =head2 FirstAttribute NAME
235 Returns the first attribute with the matching name for this object (as an
236 L<RT::Attribute> object), or C<undef> if no such attributes exist.
237 If there is more than one attribute with the matching name on the
238 object, the first value that was set is returned.
245 return ($self->Attributes->Named( $name ))[0];
249 sub ClearAttributes {
251 delete $self->{'attributes'};
255 sub _Handle { return $RT::Handle }
259 =head2 Create PARAMHASH
261 Takes a PARAMHASH of Column -> Value pairs.
262 If any Column has a Validate$PARAMNAME subroutine defined and the
263 value provided doesn't pass validation, this routine returns
266 If this object's table has any of the following atetributes defined as
267 'Auto', this routine will automatically fill in their values.
286 foreach my $key ( keys %attribs ) {
287 if (my $method = $self->can("Validate$key")) {
288 if (! $method->( $self, $attribs{$key} ) ) {
290 return ( 0, $self->loc('Invalid value for [_1]', $key) );
301 my ($sec,$min,$hour,$mday,$mon,$year,$wday,$ydaym,$isdst,$offset) = gmtime();
304 sprintf("%04d-%02d-%02d %02d:%02d:%02d", ($year+1900), ($mon+1), $mday, $hour, $min, $sec);
306 $attribs{'Created'} = $now_iso if ( $self->_Accessible( 'Created', 'auto' ) && !$attribs{'Created'});
308 if ($self->_Accessible( 'Creator', 'auto' ) && !$attribs{'Creator'}) {
309 $attribs{'Creator'} = $self->CurrentUser->id || '0';
311 $attribs{'LastUpdated'} = $now_iso
312 if ( $self->_Accessible( 'LastUpdated', 'auto' ) && !$attribs{'LastUpdated'});
314 $attribs{'LastUpdatedBy'} = $self->CurrentUser->id || '0'
315 if ( $self->_Accessible( 'LastUpdatedBy', 'auto' ) && !$attribs{'LastUpdatedBy'});
317 my $id = $self->SUPER::Create(%attribs);
318 if ( UNIVERSAL::isa( $id, 'Class::ReturnValue' ) ) {
322 $self->loc( "Internal Error: [_1]", $id->{error_message} ) );
329 # If the object was created in the database,
330 # load it up now, so we're sure we get what the database
331 # has. Arguably, this should not be necessary, but there
332 # isn't much we can do about it.
336 return ( $id, $self->loc('Object could not be created') );
344 if (UNIVERSAL::isa('errno',$id)) {
348 $self->Load($id) if ($id);
353 return ( $id, $self->loc('Object created') );
365 Override DBIx::SearchBuilder::LoadByCols to do case-insensitive loads if the
373 # We don't want to hang onto this
374 $self->ClearAttributes;
376 return $self->SUPER::LoadByCols( @_ ) unless $self->_Handle->CaseSensitive;
378 # If this database is case sensitive we need to uncase objects for
381 foreach my $key ( keys %hash ) {
383 # If we've been passed an empty value, we can't do the lookup.
384 # We don't need to explicitly downcase integers or an id.
385 if ( $key ne 'id' && defined $hash{ $key } && $hash{ $key } !~ /^\d+$/ ) {
386 my ($op, $val, $func);
387 ($key, $op, $val, $func) =
388 $self->_Handle->_MakeClauseCaseInsensitive( $key, '=', delete $hash{ $key } );
389 $hash{$key}->{operator} = $op;
390 $hash{$key}->{value} = $val;
391 $hash{$key}->{function} = $func;
394 return $self->SUPER::LoadByCols( %hash );
399 # There is room for optimizations in most of those subs:
404 my $obj = RT::Date->new( $self->CurrentUser );
406 $obj->Set( Format => 'sql', Value => $self->LastUpdated );
414 my $obj = RT::Date->new( $self->CurrentUser );
416 $obj->Set( Format => 'sql', Value => $self->Created );
423 # TODO: This should be deprecated
427 return ( $self->CreatedObj->AgeAsString() );
432 # TODO this should be deprecated
434 sub LastUpdatedAsString {
436 if ( $self->LastUpdated ) {
437 return ( $self->LastUpdatedObj->AsString() );
447 # TODO This should be deprecated
449 sub CreatedAsString {
451 return ( $self->CreatedObj->AsString() );
456 # TODO This should be deprecated
458 sub LongSinceUpdateAsString {
460 if ( $self->LastUpdated ) {
462 return ( $self->LastUpdatedObj->AgeAsString() );
483 #if the user is trying to modify the record
484 # TODO: document _why_ this code is here
486 if ( ( !defined( $args{'Field'} ) ) || ( !defined( $args{'Value'} ) ) ) {
490 my $old_val = $self->__Value($args{'Field'});
491 $self->_SetLastUpdated();
492 my $ret = $self->SUPER::_Set(
493 Field => $args{'Field'},
494 Value => $args{'Value'},
495 IsSQL => $args{'IsSQL'}
497 my ($status, $msg) = $ret->as_array();
499 # @values has two values, a status code and a message.
501 # $ret is a Class::ReturnValue object. as such, in a boolean context, it's a bool
502 # we want to change the standard "success" message
504 if ($self->SQLType( $args{'Field'}) =~ /text/) {
507 $self->loc( $args{'Field'} ),
511 "[_1] changed from [_2] to [_3]",
512 $self->loc( $args{'Field'} ),
513 ( $old_val ? '"' . $old_val . '"' : $self->loc("(no value)") ),
514 '"' . $self->__Value( $args{'Field'}) . '"',
518 $msg = $self->CurrentUser->loc_fuzzy($msg);
521 return wantarray ? ($status, $msg) : $ret;
526 =head2 _SetLastUpdated
528 This routine updates the LastUpdated and LastUpdatedBy columns of the row in question
529 It takes no options. Arguably, this is a bug
533 sub _SetLastUpdated {
536 my $now = RT::Date->new( $self->CurrentUser );
539 if ( $self->_Accessible( 'LastUpdated', 'auto' ) ) {
540 my ( $msg, $val ) = $self->__Set(
541 Field => 'LastUpdated',
545 if ( $self->_Accessible( 'LastUpdatedBy', 'auto' ) ) {
546 my ( $msg, $val ) = $self->__Set(
547 Field => 'LastUpdatedBy',
548 Value => $self->CurrentUser->id
557 Returns an RT::User object with the RT account of the creator of this row
563 unless ( exists $self->{'CreatorObj'} ) {
565 $self->{'CreatorObj'} = RT::User->new( $self->CurrentUser );
566 $self->{'CreatorObj'}->Load( $self->Creator );
568 return ( $self->{'CreatorObj'} );
573 =head2 LastUpdatedByObj
575 Returns an RT::User object of the last user to touch this object
579 sub LastUpdatedByObj {
581 unless ( exists $self->{LastUpdatedByObj} ) {
582 $self->{'LastUpdatedByObj'} = RT::User->new( $self->CurrentUser );
583 $self->{'LastUpdatedByObj'}->Load( $self->LastUpdatedBy );
585 return $self->{'LastUpdatedByObj'};
592 Returns this record's URI
598 my $uri = RT::URI::fsck_com_rt->new($self->CurrentUser);
599 return($uri->URIForObject($self));
603 =head2 ValidateName NAME
605 Validate the name of the record we're creating. Mostly, just make sure it's not a numeric ID, which is invalid for Name
612 if (defined $value && $value=~ /^\d+$/) {
621 =head2 SQLType attribute
623 return the SQL type for the attribute 'attribute' as stored in _ClassAccessible
631 return ($self->_Accessible($field, 'type'));
639 my %args = ( decode_utf8 => 1, @_ );
642 $RT::Logger->error("__Value called with undef field");
645 my $value = $self->SUPER::__Value($field);
647 return undef if (!defined $value);
649 if ( $args{'decode_utf8'} ) {
650 if ( !utf8::is_utf8($value) ) {
651 utf8::decode($value);
655 if ( utf8::is_utf8($value) ) {
656 utf8::encode($value);
664 # Set up defaults for DBIx::SearchBuilder::Record::Cachable
669 'cache_for_sec' => 30,
675 sub _BuildTableAttributes {
677 my $class = ref($self) || $self;
680 if ( UNIVERSAL::can( $self, '_CoreAccessible' ) ) {
681 $attributes = $self->_CoreAccessible();
682 } elsif ( UNIVERSAL::can( $self, '_ClassAccessible' ) ) {
683 $attributes = $self->_ClassAccessible();
687 foreach my $column (keys %$attributes) {
688 foreach my $attr ( keys %{ $attributes->{$column} } ) {
689 $_TABLE_ATTR->{$class}->{$column}->{$attr} = $attributes->{$column}->{$attr};
692 foreach my $method ( qw(_OverlayAccessible _VendorAccessible _LocalAccessible) ) {
693 next unless UNIVERSAL::can( $self, $method );
694 $attributes = $self->$method();
696 foreach my $column ( keys %$attributes ) {
697 foreach my $attr ( keys %{ $attributes->{$column} } ) {
698 $_TABLE_ATTR->{$class}->{$column}->{$attr} = $attributes->{$column}->{$attr};
705 =head2 _ClassAccessible
707 Overrides the "core" _ClassAccessible using $_TABLE_ATTR. Behaves identical to the version in
708 DBIx::SearchBuilder::Record
712 sub _ClassAccessible {
714 return $_TABLE_ATTR->{ref($self) || $self};
717 =head2 _Accessible COLUMN ATTRIBUTE
719 returns the value of ATTRIBUTE for COLUMN
727 my $attribute = lc(shift);
728 return 0 unless defined ($_TABLE_ATTR->{ref($self)}->{$column});
729 return $_TABLE_ATTR->{ref($self)}->{$column}->{$attribute} || 0;
733 =head2 _EncodeLOB BODY MIME_TYPE FILENAME
735 Takes a potentially large attachment. Returns (ContentEncoding,
736 EncodedBody, MimeType, Filename) based on system configuration and
737 selected database. Returns a custom (short) text/plain message if
738 DropLongAttachments causes an attachment to not be stored.
740 Encodes your data as base64 or Quoted-Printable as needed based on your
741 Databases's restrictions and the UTF-8ness of the data being passed in. Since
742 we are storing in columns marked UTF8, we must ensure that binary data is
743 encoded on databases which are strict.
745 This function expects to receive an octet string in order to properly
746 evaluate and encode it. It will return an octet string.
753 my $MIMEType = shift || '';
754 my $Filename = shift;
756 my $ContentEncoding = 'none';
758 #get the max attachment length from RT
759 my $MaxSize = RT->Config->Get('MaxAttachmentSize');
761 #if the current attachment contains nulls and the
762 #database doesn't support embedded nulls
764 if ( ( !$RT::Handle->BinarySafeBLOBs ) && ( $Body =~ /\x00/ ) ) {
766 # set a flag telling us to mimencode the attachment
767 $ContentEncoding = 'base64';
769 #cut the max attchment size by 25% (for mime-encoding overhead.
770 $RT::Logger->debug("Max size is $MaxSize");
771 $MaxSize = $MaxSize * 3 / 4;
772 # Some databases (postgres) can't handle non-utf8 data
773 } elsif ( !$RT::Handle->BinarySafeBLOBs
774 && $Body =~ /\P{ASCII}/
775 && !Encode::is_utf8( $Body, 1 ) ) {
776 $ContentEncoding = 'quoted-printable';
779 #if the attachment is larger than the maximum size
780 if ( ($MaxSize) and ( $MaxSize < length($Body) ) ) {
782 # if we're supposed to truncate large attachments
783 if (RT->Config->Get('TruncateLongAttachments')) {
785 # truncate the attachment to that length.
786 $Body = substr( $Body, 0, $MaxSize );
790 # elsif we're supposed to drop large attachments on the floor,
791 elsif (RT->Config->Get('DropLongAttachments')) {
793 # drop the attachment on the floor
794 $RT::Logger->info( "$self: Dropped an attachment of size "
796 $RT::Logger->info( "It started: " . substr( $Body, 0, 60 ) );
797 $Filename .= ".txt" if $Filename;
798 return ("none", "Large attachment dropped", "text/plain", $Filename );
802 # if we need to mimencode the attachment
803 if ( $ContentEncoding eq 'base64' ) {
805 # base64 encode the attachment
806 Encode::_utf8_off($Body);
807 $Body = MIME::Base64::encode_base64($Body);
809 } elsif ($ContentEncoding eq 'quoted-printable') {
810 Encode::_utf8_off($Body);
811 $Body = MIME::QuotedPrint::encode($Body);
815 return ($ContentEncoding, $Body, $MIMEType, $Filename );
821 Unpacks data stored in the database, which may be base64 or QP encoded
822 because of our need to store binary and badly encoded data in columns
823 marked as UTF-8. Databases such as PostgreSQL and Oracle care that you
824 are feeding them invalid UTF-8 and will refuse the content. This
825 function handles unpacking the encoded data.
827 It returns textual data as a UTF-8 string which has been processed by Encode's
828 PERLQQ filter which will replace the invalid bytes with \x{HH} so you can see
829 the invalid byte but won't run into problems treating the data as UTF-8 later.
831 This is similar to how we filter all data coming in via the web UI in
832 RT::Interface::Web::DecodeARGS. This filter should only end up being
833 applied to old data from less UTF-8-safe versions of RT.
835 Important Note - This function expects an octet string and returns a
836 character string for non-binary data.
842 my $ContentType = shift || '';
843 my $ContentEncoding = shift || 'none';
846 if ( $ContentEncoding eq 'base64' ) {
847 $Content = MIME::Base64::decode_base64($Content);
849 elsif ( $ContentEncoding eq 'quoted-printable' ) {
850 $Content = MIME::QuotedPrint::decode($Content);
852 elsif ( $ContentEncoding && $ContentEncoding ne 'none' ) {
853 return ( $self->loc( "Unknown ContentEncoding [_1]", $ContentEncoding ) );
855 if ( RT::I18N::IsTextualContentType($ContentType) ) {
856 $Content = Encode::decode('UTF-8',$Content,Encode::FB_PERLQQ) unless Encode::is_utf8($Content);
861 # A helper table for links mapping to make it easier
862 # to build and parse links between tickets
864 use vars '%LINKDIRMAP';
867 MemberOf => { Base => 'MemberOf',
868 Target => 'HasMember', },
869 RefersTo => { Base => 'RefersTo',
870 Target => 'ReferredToBy', },
871 DependsOn => { Base => 'DependsOn',
872 Target => 'DependedOnBy', },
873 MergedInto => { Base => 'MergedInto',
874 Target => 'MergedInto', },
878 =head2 Update ARGSHASH
880 Updates fields on an object for you using the proper Set methods,
881 skipping unchanged values.
883 ARGSRef => a hashref of attributes => value for the update
884 AttributesRef => an arrayref of keys in ARGSRef that should be updated
885 AttributePrefix => a prefix that should be added to the attributes in AttributesRef
886 when looking up values in ARGSRef
887 Bare attributes are tried before prefixed attributes
889 Returns a list of localized results of the update
898 AttributesRef => undef,
899 AttributePrefix => undef,
903 my $attributes = $args{'AttributesRef'};
904 my $ARGSRef = $args{'ARGSRef'};
907 # gather all new values
908 foreach my $attribute (@$attributes) {
910 if ( defined $ARGSRef->{$attribute} ) {
911 $value = $ARGSRef->{$attribute};
914 defined( $args{'AttributePrefix'} )
916 $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute }
919 $value = $ARGSRef->{ $args{'AttributePrefix'} . "-" . $attribute };
926 $value =~ s/\r\n/\n/gs;
928 my $truncated_value = $self->TruncateValue($attribute, $value);
930 # If Queue is 'General', we want to resolve the queue name for
933 # This is in an eval block because $object might not exist.
934 # and might not have a Name method. But "can" won't find autoloaded
935 # items. If it fails, we don't care
937 no warnings "uninitialized";
940 my $object = $attribute . "Obj";
941 my $name = $self->$object->Name;
942 next if $name eq $value || $name eq ($value || 0);
945 my $current = $self->$attribute();
946 # RT::Queue->Lifecycle returns a Lifecycle object instead of name
947 $current = eval { $current->Name } if ref $current;
948 next if $truncated_value eq $current;
949 next if ( $truncated_value || 0 ) eq $current;
952 $new_values{$attribute} = $value;
955 return $self->_UpdateAttributes(
956 Attributes => $attributes,
957 NewValues => \%new_values,
961 sub _UpdateAttributes {
971 foreach my $attribute (@{ $args{Attributes} }) {
972 next if !exists($args{NewValues}{$attribute});
974 my $value = $args{NewValues}{$attribute};
975 my $method = "Set$attribute";
976 my ( $code, $msg ) = $self->$method($value);
977 my ($prefix) = ref($self) =~ /RT(?:.*)::(\w+)/;
979 # Default to $id, but use name if we can get it.
980 my $label = $self->id;
981 $label = $self->Name if (UNIVERSAL::can($self,'Name'));
982 # this requires model names to be loc'ed.
993 push @results, $self->loc( $prefix ) . " $label: ". $msg;
997 "[_1] could not be set to [_2].", # loc
998 "That is already the current value", # loc
999 "No value sent to _Set!", # loc
1000 "Illegal value for [_1]", # loc
1001 "The new value has been set.", # loc
1002 "No column specified", # loc
1003 "Immutable field", # loc
1004 "Nonexistant field?", # loc
1005 "Invalid data", # loc
1006 "Couldn't find row", # loc
1007 "Missing a primary key?: [_1]", # loc
1008 "Found Object", # loc
1022 This returns an RT::Links object which references all the tickets
1023 which are 'MembersOf' this ticket
1029 return ( $self->_Links( 'Target', 'MemberOf' ) );
1036 This returns an RT::Links object which references all the tickets that this
1037 ticket is a 'MemberOf'
1043 return ( $self->_Links( 'Base', 'MemberOf' ) );
1050 This returns an RT::Links object which shows all references for which this ticket is a base
1056 return ( $self->_Links( 'Base', 'RefersTo' ) );
1063 This returns an L<RT::Links> object which shows all references for which this ticket is a target
1069 return ( $self->_Links( 'Target', 'RefersTo' ) );
1076 This returns an RT::Links object which references all the tickets that depend on this one
1082 return ( $self->_Links( 'Target', 'DependsOn' ) );
1088 =head2 HasUnresolvedDependencies
1090 Takes a paramhash of Type (default to '__any'). Returns the number of
1091 unresolved dependencies, if $self->UnresolvedDependencies returns an
1092 object with one or more members of that type. Returns false
1097 sub HasUnresolvedDependencies {
1104 my $deps = $self->UnresolvedDependencies;
1107 $deps->Limit( FIELD => 'Type',
1109 VALUE => $args{Type});
1115 if ($deps->Count > 0) {
1116 return $deps->Count;
1125 =head2 UnresolvedDependencies
1127 Returns an RT::Tickets object of tickets which this ticket depends on
1128 and which have a status of new, open or stalled. (That list comes from
1129 RT::Queue->ActiveStatusArray
1134 sub UnresolvedDependencies {
1136 my $deps = RT::Tickets->new($self->CurrentUser);
1138 my @live_statuses = RT::Queue->ActiveStatusArray();
1139 foreach my $status (@live_statuses) {
1140 $deps->LimitStatus(VALUE => $status);
1142 $deps->LimitDependedOnBy($self->Id);
1150 =head2 AllDependedOnBy
1152 Returns an array of RT::Ticket objects which (directly or indirectly)
1153 depends on this ticket; takes an optional 'Type' argument in the param
1154 hash, which will limit returned tickets to that type, as well as cause
1155 tickets with that type to serve as 'leaf' nodes that stops the recursive
1160 sub AllDependedOnBy {
1162 return $self->_AllLinkedTickets( LinkType => 'DependsOn',
1163 Direction => 'Target', @_ );
1168 Returns an array of RT::Ticket objects which this ticket (directly or
1169 indirectly) depends on; takes an optional 'Type' argument in the param
1170 hash, which will limit returned tickets to that type, as well as cause
1171 tickets with that type to serve as 'leaf' nodes that stops the
1172 recursive dependency search.
1178 return $self->_AllLinkedTickets( LinkType => 'DependsOn',
1179 Direction => 'Base', @_ );
1182 sub _AllLinkedTickets {
1194 my $dep = $self->_Links( $args{Direction}, $args{LinkType});
1195 while (my $link = $dep->Next()) {
1196 my $uri = $args{Direction} eq 'Target' ? $link->BaseURI : $link->TargetURI;
1197 next unless ($uri->IsLocal());
1198 my $obj = $args{Direction} eq 'Target' ? $link->BaseObj : $link->TargetObj;
1199 next if $args{_found}{$obj->Id};
1202 $args{_found}{$obj->Id} = $obj;
1203 $obj->_AllLinkedTickets( %args, _top => 0 );
1205 elsif ($obj->Type and $obj->Type eq $args{Type}) {
1206 $args{_found}{$obj->Id} = $obj;
1209 $obj->_AllLinkedTickets( %args, _top => 0 );
1214 return map { $args{_found}{$_} } sort keys %{$args{_found}};
1225 This returns an RT::Links object which references all the tickets that this ticket depends on
1231 return ( $self->_Links( 'Base', 'DependsOn' ) );
1240 This returns an RT::Links object which references all the customers that
1241 this object is a member of. This includes both explicitly linked customers
1242 and links implied by services.
1247 my( $self, %opt ) = @_;
1248 my $Debug = $opt{'Debug'};
1250 unless ( $self->{'Customers'} ) {
1252 $self->{'Customers'} = $self->MemberOf->Clone;
1254 for my $fstable (qw(cust_main cust_svc)) {
1256 $self->{'Customers'}->Limit(
1258 OPERATOR => 'STARTSWITH',
1259 VALUE => "freeside://freeside/$fstable",
1260 ENTRYAGGREGATOR => 'OR',
1261 SUBCLAUSE => 'customers',
1266 warn "->Customers method called on $self; returning ".
1267 ref($self->{'Customers'}). ' object'
1270 return $self->{'Customers'};
1279 This returns an RT::Links object which references all the services this
1280 object is a member of.
1285 my( $self, %opt ) = @_;
1287 unless ( $self->{'Services'} ) {
1289 $self->{'Services'} = $self->MemberOf->Clone;
1291 $self->{'Services'}->Limit(
1293 OPERATOR => 'STARTSWITH',
1294 VALUE => "freeside://freeside/cust_svc",
1298 return $self->{'Services'};
1306 =head2 Links DIRECTION [TYPE]
1308 Return links (L<RT::Links>) to/from this object.
1310 DIRECTION is either 'Base' or 'Target'.
1312 TYPE is a type of links to return, it can be omitted to get
1317 sub Links { shift->_Links(@_) }
1322 #TODO: Field isn't the right thing here. but I ahave no idea what mnemonic ---
1325 my $type = shift || "";
1327 unless ( $self->{"$field$type"} ) {
1328 $self->{"$field$type"} = RT::Links->new( $self->CurrentUser );
1329 # at least to myself
1330 $self->{"$field$type"}->Limit( FIELD => $field,
1331 VALUE => $self->URI,
1332 ENTRYAGGREGATOR => 'OR' );
1333 $self->{"$field$type"}->Limit( FIELD => 'Type',
1337 return ( $self->{"$field$type"} );
1345 Takes a Type and returns a string that is more human readable.
1351 my %args = ( Type => '',
1354 $args{Type} =~ s/([A-Z])/" " . lc $1/ge;
1355 $args{Type} =~ s/^\s+//;
1364 Takes either a Target or a Base and returns a string of human friendly text.
1370 my %args = ( Object => undef,
1374 my $text = "URI " . $args{FallBack};
1375 if ($args{Object} && $args{Object}->isa("RT::Ticket")) {
1376 $text = "Ticket " . $args{Object}->id;
1385 Takes a paramhash of Type and one of Base or Target. Adds that link to this object.
1387 Returns C<link id>, C<message> and C<exist> flag.
1394 my %args = ( Target => '',
1401 # Remote_link is the URI of the object that is not this ticket
1405 if ( $args{'Base'} and $args{'Target'} ) {
1406 $RT::Logger->debug( "$self tried to create a link. both base and target were specified" );
1407 return ( 0, $self->loc("Can't specify both base and target") );
1409 elsif ( $args{'Base'} ) {
1410 $args{'Target'} = $self->URI();
1411 $remote_link = $args{'Base'};
1412 $direction = 'Target';
1414 elsif ( $args{'Target'} ) {
1415 $args{'Base'} = $self->URI();
1416 $remote_link = $args{'Target'};
1417 $direction = 'Base';
1420 return ( 0, $self->loc('Either base or target must be specified') );
1423 # Check if the link already exists - we don't want duplicates
1425 my $old_link = RT::Link->new( $self->CurrentUser );
1426 $old_link->LoadByParams( Base => $args{'Base'},
1427 Type => $args{'Type'},
1428 Target => $args{'Target'} );
1429 if ( $old_link->Id ) {
1430 $RT::Logger->debug("$self Somebody tried to duplicate a link");
1431 return ( $old_link->id, $self->loc("Link already exists"), 1 );
1437 # Storing the link in the DB.
1438 my $link = RT::Link->new( $self->CurrentUser );
1439 my ($linkid, $linkmsg) = $link->Create( Target => $args{Target},
1440 Base => $args{Base},
1441 Type => $args{Type} );
1444 $RT::Logger->error("Link could not be created: ".$linkmsg);
1445 return ( 0, $self->loc("Link could not be created") );
1448 my $basetext = $self->FormatLink(Object => $link->BaseObj,
1449 FallBack => $args{Base});
1450 my $targettext = $self->FormatLink(Object => $link->TargetObj,
1451 FallBack => $args{Target});
1452 my $typetext = $self->FormatType(Type => $args{Type});
1454 "$basetext $typetext $targettext.";
1455 return ( $linkid, $TransString ) ;
1462 Delete a link. takes a paramhash of Base, Target and Type.
1463 Either Base or Target must be null. The null value will
1464 be replaced with this ticket's id
1477 #we want one of base and target. we don't care which
1478 #but we only want _one_
1483 if ( $args{'Base'} and $args{'Target'} ) {
1484 $RT::Logger->debug("$self ->_DeleteLink. got both Base and Target");
1485 return ( 0, $self->loc("Can't specify both base and target") );
1487 elsif ( $args{'Base'} ) {
1488 $args{'Target'} = $self->URI();
1489 $remote_link = $args{'Base'};
1490 $direction = 'Target';
1492 elsif ( $args{'Target'} ) {
1493 $args{'Base'} = $self->URI();
1494 $remote_link = $args{'Target'};
1498 $RT::Logger->error("Base or Target must be specified");
1499 return ( 0, $self->loc('Either base or target must be specified') );
1502 my $link = RT::Link->new( $self->CurrentUser );
1503 $RT::Logger->debug( "Trying to load link: " . $args{'Base'} . " " . $args{'Type'} . " " . $args{'Target'} );
1506 $link->LoadByParams( Base=> $args{'Base'}, Type=> $args{'Type'}, Target=> $args{'Target'} );
1510 my $basetext = $self->FormatLink(Object => $link->BaseObj,
1511 FallBack => $args{Base});
1512 my $targettext = $self->FormatLink(Object => $link->TargetObj,
1513 FallBack => $args{Target});
1514 my $typetext = $self->FormatType(Type => $args{Type});
1515 my $linkid = $link->id;
1517 my $TransString = "$basetext no longer $typetext $targettext.";
1518 return ( 1, $TransString);
1521 #if it's not a link we can find
1523 $RT::Logger->debug("Couldn't find that link");
1524 return ( 0, $self->loc("Link not found") );
1529 =head1 LockForUpdate
1531 In a database transaction, gains an exclusive lock on the row, to
1532 prevent race conditions. On SQLite, this is a "RESERVED" lock on the
1540 my $pk = $self->_PrimaryKey;
1541 my $id = @_ ? $_[0] : $self->$pk;
1542 $self->_expire if $self->isa("DBIx::SearchBuilder::Record::Cachable");
1543 if (RT->Config->Get('DatabaseType') eq "SQLite") {
1544 # SQLite does DB-level locking, upgrading the transaction to
1545 # "RESERVED" on the first UPDATE/INSERT/DELETE. Do a no-op
1546 # UPDATE to force the upgade.
1547 return RT->DatabaseHandle->dbh->do(
1548 "UPDATE " .$self->Table.
1549 " SET $pk = $pk WHERE 1 = 0");
1551 return $self->_LoadFromSQL(
1552 "SELECT * FROM ".$self->Table
1553 ." WHERE $pk = ? FOR UPDATE",
1559 =head2 _NewTransaction PARAMHASH
1561 Private function to create a new RT::Transaction object for this ticket update
1565 sub _NewTransaction {
1572 OldReference => undef,
1573 NewReference => undef,
1574 ReferenceType => undef,
1578 ActivateScrips => 1,
1580 SquelchMailTo => undef,
1585 my $in_txn = RT->DatabaseHandle->TransactionDepth;
1586 RT->DatabaseHandle->BeginTransaction unless $in_txn;
1588 $self->LockForUpdate;
1590 my $old_ref = $args{'OldReference'};
1591 my $new_ref = $args{'NewReference'};
1592 my $ref_type = $args{'ReferenceType'};
1593 if ($old_ref or $new_ref) {
1594 $ref_type ||= ref($old_ref) || ref($new_ref);
1596 $RT::Logger->error("Reference type not specified for transaction");
1599 $old_ref = $old_ref->Id if ref($old_ref);
1600 $new_ref = $new_ref->Id if ref($new_ref);
1603 require RT::Transaction;
1604 my $trans = RT::Transaction->new( $self->CurrentUser );
1605 my ( $transaction, $msg ) = $trans->Create(
1606 ObjectId => $self->Id,
1607 ObjectType => ref($self),
1608 TimeTaken => $args{'TimeTaken'},
1609 Type => $args{'Type'},
1610 Data => $args{'Data'},
1611 Field => $args{'Field'},
1612 NewValue => $args{'NewValue'},
1613 OldValue => $args{'OldValue'},
1614 NewReference => $new_ref,
1615 OldReference => $old_ref,
1616 ReferenceType => $ref_type,
1617 MIMEObj => $args{'MIMEObj'},
1618 ActivateScrips => $args{'ActivateScrips'},
1619 CommitScrips => $args{'CommitScrips'},
1620 SquelchMailTo => $args{'SquelchMailTo'},
1621 CustomFields => $args{'CustomFields'},
1624 # Rationalize the object since we may have done things to it during the caching.
1625 $self->Load($self->Id);
1627 $RT::Logger->warning($msg) unless $transaction;
1629 $self->_SetLastUpdated;
1631 if ( defined $args{'TimeTaken'} and $self->can('_UpdateTimeTaken')) {
1632 $self->_UpdateTimeTaken( $args{'TimeTaken'} );
1634 if ( RT->Config->Get('UseTransactionBatch') and $transaction ) {
1635 push @{$self->{_TransactionBatch}}, $trans if $args{'CommitScrips'};
1638 RT->DatabaseHandle->Commit unless $in_txn;
1640 return ( $transaction, $msg, $trans );
1647 Returns an RT::Transactions object of all transactions on this record object
1654 use RT::Transactions;
1655 my $transactions = RT::Transactions->new( $self->CurrentUser );
1657 #If the user has no rights, return an empty object
1658 $transactions->Limit(
1659 FIELD => 'ObjectId',
1662 $transactions->Limit(
1663 FIELD => 'ObjectType',
1664 VALUE => ref($self),
1667 return ($transactions);
1674 my $cfs = RT::CustomFields->new( $self->CurrentUser );
1676 $cfs->SetContextObject( $self );
1677 # XXX handle multiple types properly
1678 $cfs->LimitToLookupType( $self->CustomFieldLookupType );
1679 $cfs->LimitToGlobalOrObjectId( $self->CustomFieldLookupId );
1680 $cfs->ApplySortOrder;
1685 # TODO: This _only_ works for RT::Foo classes. it doesn't work, for
1686 # example, for RT::IR::Foo classes.
1688 sub CustomFieldLookupId {
1690 my $lookup = shift || $self->CustomFieldLookupType;
1691 my @classes = ($lookup =~ /RT::(\w+)-/g);
1693 # Work on "RT::Queue", for instance
1694 return $self->Id unless @classes;
1697 # Save a ->Load call by not calling ->FooObj->Id, just ->Foo
1698 my $final = shift @classes;
1699 foreach my $class (reverse @classes) {
1700 my $method = "${class}Obj";
1701 $object = $object->$method;
1704 my $id = $object->$final;
1705 unless (defined $id) {
1706 my $method = "${final}Obj";
1707 $id = $object->$method->Id;
1713 =head2 CustomFieldLookupType
1715 Returns the path RT uses to figure out which custom fields apply to this object.
1719 sub CustomFieldLookupType {
1721 return ref($self) || $self;
1725 =head2 AddCustomFieldValue { Field => FIELD, Value => VALUE }
1727 VALUE should be a string. FIELD can be any identifier of a CustomField
1728 supported by L</LoadCustomFieldByIdentifier> method.
1730 Adds VALUE as a value of CustomField FIELD. If this is a single-value custom field,
1731 deletes the old value.
1732 If VALUE is not a valid value for the custom field, returns
1733 (0, 'Error message' ) otherwise, returns ($id, 'Success Message') where
1734 $id is ID of created L<ObjectCustomFieldValue> object.
1738 sub AddCustomFieldValue {
1740 $self->_AddCustomFieldValue(@_);
1743 sub _AddCustomFieldValue {
1748 LargeContent => undef,
1749 ContentType => undef,
1750 RecordTransaction => 1,
1754 my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
1755 unless ( $cf->Id ) {
1756 return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
1759 my $OCFs = $self->CustomFields;
1760 $OCFs->Limit( FIELD => 'id', VALUE => $cf->Id );
1761 unless ( $OCFs->Count ) {
1765 "Custom field [_1] does not apply to this object",
1766 ref $args{'Field'} ? $args{'Field'}->id : $args{'Field'}
1771 # empty string is not correct value of any CF, so undef it
1772 foreach ( qw(Value LargeContent) ) {
1773 $args{ $_ } = undef if defined $args{ $_ } && !length $args{ $_ };
1776 unless ( $cf->ValidateValue( $args{'Value'} ) ) {
1777 return ( 0, $self->loc("Invalid value for custom field") );
1780 # If the custom field only accepts a certain # of values, delete the existing
1781 # value and record a "changed from foo to bar" transaction
1782 unless ( $cf->UnlimitedValues ) {
1784 # Load up a ObjectCustomFieldValues object for this custom field and this ticket
1785 my $values = $cf->ValuesForObject($self);
1787 # We need to whack any old values here. In most cases, the custom field should
1788 # only have one value to delete. In the pathalogical case, this custom field
1789 # used to be a multiple and we have many values to whack....
1790 my $cf_values = $values->Count;
1792 if ( $cf_values > $cf->MaxValues ) {
1793 my $i = 0; #We want to delete all but the max we can currently have , so we can then
1794 # execute the same code to "change" the value from old to new
1795 while ( my $value = $values->Next ) {
1797 if ( $i < $cf_values ) {
1798 my ( $val, $msg ) = $cf->DeleteValueForObject(
1805 my ( $TransactionId, $Msg, $TransactionObj ) =
1806 $self->_NewTransaction(
1807 Type => 'CustomField',
1809 OldReference => $value,
1813 $values->RedoSearch if $i; # redo search if have deleted at least one value
1816 if ( my $entry = $values->HasEntry($args{'Value'}, $args{'LargeContent'}) ) {
1820 my $old_value = $values->First;
1822 $old_content = $old_value->Content if $old_value;
1824 my ( $new_value_id, $value_msg ) = $cf->AddValueForObject(
1826 Content => $args{'Value'},
1827 LargeContent => $args{'LargeContent'},
1828 ContentType => $args{'ContentType'},
1831 unless ( $new_value_id ) {
1832 return ( 0, $self->loc( "Could not add new custom field value: [_1]", $value_msg ) );
1835 my $new_value = RT::ObjectCustomFieldValue->new( $self->CurrentUser );
1836 $new_value->Load( $new_value_id );
1838 # now that adding the new value was successful, delete the old one
1840 my ( $val, $msg ) = $old_value->Delete();
1841 return ( 0, $msg ) unless $val;
1844 if ( $args{'RecordTransaction'} ) {
1845 my ( $TransactionId, $Msg, $TransactionObj ) =
1846 $self->_NewTransaction(
1847 Type => 'CustomField',
1849 OldReference => $old_value,
1850 NewReference => $new_value,
1854 my $new_content = $new_value->Content;
1856 # For datetime, we need to display them in "human" format in result message
1857 #XXX TODO how about date without time?
1858 if ($cf->Type eq 'DateTime') {
1859 my $DateObj = RT::Date->new( $self->CurrentUser );
1862 Value => $new_content,
1864 $new_content = $DateObj->AsString;
1866 if ( defined $old_content && length $old_content ) {
1869 Value => $old_content,
1871 $old_content = $DateObj->AsString;
1875 unless ( defined $old_content && length $old_content ) {
1876 return ( $new_value_id, $self->loc( "[_1] [_2] added", $cf->Name, $new_content ));
1878 elsif ( !defined $new_content || !length $new_content ) {
1879 return ( $new_value_id,
1880 $self->loc( "[_1] [_2] deleted", $cf->Name, $old_content ) );
1883 return ( $new_value_id, $self->loc( "[_1] [_2] changed to [_3]", $cf->Name, $old_content, $new_content));
1888 # otherwise, just add a new value and record "new value added"
1890 if ( !$cf->Repeated ) {
1891 my $values = $cf->ValuesForObject($self);
1892 if ( my $entry = $values->HasEntry($args{'Value'}, $args{'LargeContent'}) ) {
1897 my ($new_value_id, $msg) = $cf->AddValueForObject(
1899 Content => $args{'Value'},
1900 LargeContent => $args{'LargeContent'},
1901 ContentType => $args{'ContentType'},
1904 unless ( $new_value_id ) {
1905 return ( 0, $self->loc( "Could not add new custom field value: [_1]", $msg ) );
1907 if ( $args{'RecordTransaction'} ) {
1908 my ( $tid, $msg ) = $self->_NewTransaction(
1909 Type => 'CustomField',
1911 NewReference => $new_value_id,
1912 ReferenceType => 'RT::ObjectCustomFieldValue',
1915 return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $msg ) );
1918 return ( $new_value_id, $self->loc( "[_1] added as a value for [_2]", $args{'Value'}, $cf->Name ) );
1924 =head2 DeleteCustomFieldValue { Field => FIELD, Value => VALUE }
1926 Deletes VALUE as a value of CustomField FIELD.
1928 VALUE can be a string, a CustomFieldValue or a ObjectCustomFieldValue.
1930 If VALUE is not a valid value for the custom field, returns
1931 (0, 'Error message' ) otherwise, returns (1, 'Success Message')
1935 sub DeleteCustomFieldValue {
1944 my $cf = $self->LoadCustomFieldByIdentifier($args{'Field'});
1945 unless ( $cf->Id ) {
1946 return ( 0, $self->loc( "Custom field [_1] not found", $args{'Field'} ) );
1949 my ( $val, $msg ) = $cf->DeleteValueForObject(
1951 Id => $args{'ValueId'},
1952 Content => $args{'Value'},
1958 my ( $TransactionId, $Msg, $TransactionObj ) = $self->_NewTransaction(
1959 Type => 'CustomField',
1961 OldReference => $val,
1962 ReferenceType => 'RT::ObjectCustomFieldValue',
1964 unless ($TransactionId) {
1965 return ( 0, $self->loc( "Couldn't create a transaction: [_1]", $Msg ) );
1968 my $old_value = $TransactionObj->OldValue;
1969 # For datetime, we need to display them in "human" format in result message
1970 if ( $cf->Type eq 'DateTime' ) {
1971 my $DateObj = RT::Date->new( $self->CurrentUser );
1974 Value => $old_value,
1976 $old_value = $DateObj->AsString;
1981 "[_1] is no longer a value for custom field [_2]",
1982 $old_value, $cf->Name
1989 =head2 FirstCustomFieldValue FIELD
1991 Return the content of the first value of CustomField FIELD for this ticket
1992 Takes a field id or name
1996 sub FirstCustomFieldValue {
2000 my $values = $self->CustomFieldValues( $field );
2001 return undef unless my $first = $values->First;
2002 return $first->Content;
2005 =head2 CustomFieldValuesAsString FIELD
2007 Return the content of the CustomField FIELD for this ticket.
2008 If this is a multi-value custom field, values will be joined with newlines.
2010 Takes a field id or name as the first argument
2012 Takes an optional Separator => "," second and third argument
2013 if you want to join the values using something other than a newline
2017 sub CustomFieldValuesAsString {
2021 my $separator = $args{Separator} || "\n";
2023 my $values = $self->CustomFieldValues( $field );
2024 return join ($separator, grep { defined $_ }
2025 map { $_->Content } @{$values->ItemsArrayRef});
2030 =head2 CustomFieldValues FIELD
2032 Return a ObjectCustomFieldValues object of all values of the CustomField whose
2033 id or Name is FIELD for this record.
2035 Returns an RT::ObjectCustomFieldValues object
2039 sub CustomFieldValues {
2044 my $cf = $self->LoadCustomFieldByIdentifier( $field );
2046 # we were asked to search on a custom field we couldn't find
2047 unless ( $cf->id ) {
2048 $RT::Logger->warning("Couldn't load custom field by '$field' identifier");
2049 return RT::ObjectCustomFieldValues->new( $self->CurrentUser );
2051 return ( $cf->ValuesForObject($self) );
2054 # we're not limiting to a specific custom field;
2055 my $ocfs = RT::ObjectCustomFieldValues->new( $self->CurrentUser );
2056 $ocfs->LimitToObject( $self );
2060 =head2 LoadCustomFieldByIdentifier IDENTIFER
2062 Find the custom field has id or name IDENTIFIER for this object.
2064 If no valid field is found, returns an empty RT::CustomField object.
2068 sub LoadCustomFieldByIdentifier {
2073 if ( UNIVERSAL::isa( $field, "RT::CustomField" ) ) {
2074 $cf = RT::CustomField->new($self->CurrentUser);
2075 $cf->SetContextObject( $self );
2076 $cf->LoadById( $field->id );
2078 elsif ($field =~ /^\d+$/) {
2079 $cf = RT::CustomField->new($self->CurrentUser);
2080 $cf->SetContextObject( $self );
2081 $cf->LoadById($field);
2084 my $cfs = $self->CustomFields($self->CurrentUser);
2085 $cfs->SetContextObject( $self );
2086 $cfs->Limit(FIELD => 'Name', VALUE => $field, CASESENSITIVE => 0);
2087 $cf = $cfs->First || RT::CustomField->new($self->CurrentUser);
2092 sub ACLEquivalenceObjects { }
2094 sub BasicColumns { }
2097 return RT->Config->Get('WebPath'). "/index.html?q=";
2100 RT::Base->_ImportOverlays();