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 }}}
58 use Scalar::Util qw(blessed);
60 use vars qw($Config $System $SystemUser $Nobody $Handle $Logger $_Privileged $_Unprivileged $_INSTALL_MODE);
77 $MasonLocalComponentRoot
82 RT->LoadGeneratedData();
90 A fully featured request tracker package.
92 This documentation describes the point-of-entry for RT's Perl API. To learn
93 more about what RT is and what it can do for you, visit
94 L<https://bestpractical.com/rt>.
100 If you're using RT's Perl libraries, you need to initialize RT before using any
103 You have the option of handling the timing of config loading and the actual
104 init sequence yourself with:
112 or you can let RT do it all:
116 This second method is particular useful when writing one-liners to interact with RT:
118 perl -MRT=-init -e '...'
120 The first method is necessary if you need to delay or conditionalize
121 initialization or if you want to fiddle with C<< RT->Config >> between loading
122 the config files and initializing the RT environment.
130 my $action = shift || '';
132 if ($action eq "-init" and not $DID_IMPORT_INIT) {
135 $DID_IMPORT_INIT = 1;
142 Load RT's config file. First, the site configuration file
143 (F<RT_SiteConfig.pm>) is loaded, in order to establish overall site
144 settings like hostname and name of RT instance. Then, the core
145 configuration file (F<RT_Config.pm>) is loaded to set fallback values
146 for all settings; it bases some values on settings from the site
149 In order for the core configuration to not override the site's
150 settings, the function C<Set> is used; it only sets values if they
151 have not been set already.
157 $Config = RT::Config->new;
158 $Config->LoadConfigs;
161 # RT::Essentials mistakenly recommends that WebPath be set to '/'.
162 # If the user does that, do what they mean.
163 $RT::WebPath = '' if ($RT::WebPath eq '/');
165 # Fix relative LogDir; It cannot be fixed in a PostLoadCheck, as
166 # they are run after logging is enabled.
167 unless ( File::Spec->file_name_is_absolute( $Config->Get('LogDir') ) ) {
168 $Config->Set( LogDir =>
169 File::Spec->catfile( $BasePath, $Config->Get('LogDir') ) );
177 L<Connects to the database|/ConnectToDatabase>, L<initilizes system
178 objects|/InitSystemObjects>, L<preloads classes|/InitClasses>, L<sets
179 up logging|/InitLogging>, and L<loads plugins|/InitPlugins>.
184 shift if @_%2; # code is inconsistent about calling as method
187 CheckPerlRequirements();
191 #Get a database connection
197 _BuildTableAttributes();
199 RT->Config->PostLoadCheck;
200 RT::Lifecycle->new->FillCache;
203 =head2 ConnectToDatabase
205 Get a database connection. See also L</Handle>.
209 sub ConnectToDatabase {
211 $Handle = RT::Handle->new unless $Handle;
218 Create the Logger object and set up signal handlers.
224 # We have to set the record separator ($, man perlvar)
225 # or Log::Dispatch starts getting
226 # really pissy, as some other module we use unsets it.
228 use Log::Dispatch 1.6;
231 map( { $_ => } 0..7 ),
236 error => 4, 'err' => 4,
237 critical => 5, crit => 5,
239 emergency => 7, emerg => 7,
242 unless ( $RT::Logger ) {
244 $RT::Logger = Log::Dispatch->new;
246 my $stack_from_level;
247 if ( $stack_from_level = RT->Config->Get('LogStackTraces') ) {
248 # if option has old style '\d'(true) value
249 $stack_from_level = 0 if $stack_from_level =~ /^\d+$/;
250 $stack_from_level = $level_to_num{ $stack_from_level } || 0;
252 $stack_from_level = 99; # don't log
255 my $simple_cb = sub {
256 # if this code throw any warning we can get segfault
260 # skip Log::* stack frames
262 $frame++ while caller($frame) && caller($frame) =~ /^Log::/;
263 my ($package, $filename, $line) = caller($frame);
265 $p{'message'} =~ s/(?:\r*\n)+$//;
266 return "[$$] [". gmtime(time) ."] [". $p{'level'} ."]: "
267 . $p{'message'} ." ($filename:$line)\n";
270 my $syslog_cb = sub {
271 # if this code throw any warning we can get segfault
275 my $frame = 0; # stack frame index
276 # skip Log::* stack frames
277 $frame++ while caller($frame) && caller($frame) =~ /^Log::/;
278 my ($package, $filename, $line) = caller($frame);
280 # syswrite() cannot take utf8; turn it off here.
281 Encode::_utf8_off($p{message});
283 $p{message} =~ s/(?:\r*\n)+$//;
284 if ($p{level} eq 'debug') {
285 return "[$$] $p{message} ($filename:$line)\n";
287 return "[$$] $p{message}\n";
294 return $p{'message'} unless $level_to_num{ $p{'level'} } >= $stack_from_level;
296 require Devel::StackTrace;
297 my $trace = Devel::StackTrace->new( ignore_class => [ 'Log::Dispatch', 'Log::Dispatch::Base' ] );
298 return $p{'message'} . $trace->as_string;
300 # skip calling of the Log::* subroutins
302 $frame++ while caller($frame) && caller($frame) =~ /^Log::/;
303 $frame++ while caller($frame) && (caller($frame))[3] =~ /^Log::/;
305 $p{'message'} .= "\nStack trace:\n";
306 while( my ($package, $filename, $line, $sub) = caller($frame++) ) {
307 $p{'message'} .= "\t$sub(...) called at $filename:$line\n";
309 return $p{'message'};
312 if ( $Config->Get('LogToFile') ) {
313 my ($filename, $logdir) = (
314 $Config->Get('LogToFileNamed') || 'rt.log',
315 $Config->Get('LogDir') || File::Spec->catdir( $VarPath, 'log' ),
317 if ( $filename =~ m![/\\]! ) { # looks like an absolute path.
318 ($logdir) = $filename =~ m{^(.*[/\\])};
321 $filename = File::Spec->catfile( $logdir, $filename );
324 unless ( -d $logdir && ( ( -f $filename && -w $filename ) || -w $logdir ) ) {
325 # localizing here would be hard when we don't have a current user yet
326 die "Log file '$filename' couldn't be written or created.\n RT can't run.";
329 require Log::Dispatch::File;
330 $RT::Logger->add( Log::Dispatch::File->new
332 min_level=> $Config->Get('LogToFile'),
333 filename=> $filename,
335 callbacks => [ $simple_cb, $stack_cb ],
338 if ( $Config->Get('LogToSTDERR') ) {
339 require Log::Dispatch::Screen;
340 $RT::Logger->add( Log::Dispatch::Screen->new
342 min_level => $Config->Get('LogToSTDERR'),
343 callbacks => [ $simple_cb, $stack_cb ],
347 if ( $Config->Get('LogToSyslog') ) {
348 require Log::Dispatch::Syslog;
349 $RT::Logger->add(Log::Dispatch::Syslog->new
352 min_level => $Config->Get('LogToSyslog'),
353 callbacks => [ $syslog_cb, $stack_cb ],
355 $Config->Get('LogToSyslogConf'),
359 InitSignalHandlers();
362 sub InitSignalHandlers {
365 ## This is the default handling of warnings and die'ings in the code
366 ## (including other used modules - maybe except for errors catched by
367 ## Mason). It will log all problems through the standard logging
368 ## mechanism (see above).
370 $SIG{__WARN__} = sub {
371 # The 'wide character' warnings has to be silenced for now, at least
372 # until HTML::Mason offers a sane way to process both raw output and
374 # use 'goto &foo' syntax to hide ANON sub from stack
375 if( index($_[0], 'Wide character in ') != 0 ) {
376 unshift @_, $RT::Logger, qw(level warning message);
377 goto &Log::Dispatch::log;
379 # Return value is used only by RT::Test to filter warnings from
380 # reaching the Test::NoWarnings catcher. If Log::Dispatch::log() ever
381 # starts returning 'IGNORE', we'll need to switch to something more
382 # clever. I don't expect that to happen.
386 #When we call die, trap it and log->crit with the value of the die.
388 $SIG{__DIE__} = sub {
389 # if we are not in eval and perl is not parsing code
390 # then rollback transactions and log RT error
391 unless ($^S || !defined $^S ) {
392 $RT::Handle->Rollback(1) if $RT::Handle;
393 $RT::Logger->crit("$_[0]") if $RT::Logger;
400 sub CheckPerlRequirements {
401 eval {require 5.010_001};
403 die sprintf "RT requires Perl v5.10.1 or newer. Your current Perl is v%vd\n", $^V;
406 # use $error here so the following "die" can still affect the global $@
413 require Scalar::Util;
414 Scalar::Util::weaken($y);
422 RT requires the Scalar::Util module be built with support for the 'weaken'
425 It is sometimes the case that operating system upgrades will replace
426 a working Scalar::Util with a non-working one. If your system was working
427 correctly up until now, this is likely the cause of the problem.
429 Please reinstall Scalar::Util, being careful to let it build with your C
430 compiler. Usually this is as simple as running the following command as
433 perl -MCPAN -e'install Scalar::Util'
442 Load all modules that define base classes.
447 shift if @_%2; # so we can call it as a function or method
450 require RT::Transactions;
451 require RT::Attachments;
453 require RT::Principals;
454 require RT::CurrentUser;
455 require RT::Templates;
457 require RT::ScripActions;
458 require RT::ScripConditions;
461 require RT::GroupMembers;
462 require RT::CustomFields;
463 require RT::CustomFieldValues;
464 require RT::ObjectCustomFields;
465 require RT::ObjectCustomFieldValues;
466 require RT::Attributes;
467 require RT::Dashboard;
468 require RT::Approval;
469 require RT::Lifecycle;
473 require RT::Articles;
476 require RT::ObjectClass;
477 require RT::ObjectClasses;
478 require RT::ObjectTopic;
479 require RT::ObjectTopics;
485 _BuildTableAttributes();
487 if ( $args{'Heavy'} ) {
488 # load scrips' modules
489 my $scrips = RT::Scrips->new(RT->SystemUser);
490 while ( my $scrip = $scrips->Next ) {
492 eval { $scrip->LoadModules } or
493 $RT::Logger->error("Invalid Scrip ".$scrip->Id.". Unable to load the Action or Condition. ".
494 "You should delete or repair this Scrip in the admin UI.\n$@\n");
497 foreach my $class ( grep $_, RT->Config->Get('CustomFieldValuesSources') ) {
499 eval "require $class; 1" or $RT::Logger->error(
500 "Class '$class' is listed in CustomFieldValuesSources option"
501 ." in the config, but we failed to load it:\n$@\n"
508 sub _BuildTableAttributes {
509 # on a cold server (just after restart) people could have an object
510 # in the session, as we deserialize it so we never call constructor
511 # of the class, so the list of accessible fields is empty and we die
512 # with "Method xxx is not implemented in RT::SomeClass"
514 # without this, we also can never call _ClassAccessible, because we
515 # won't have filled RT::Record::_TABLE_ATTR
516 $_->_BuildTableAttributes foreach qw(
531 RT::ObjectCustomField
532 RT::ObjectCustomFieldValue
544 =head2 InitSystemObjects
546 Initializes system objects: C<$RT::System>, C<< RT->SystemUser >>
547 and C<< RT->Nobody >>.
551 sub InitSystemObjects {
553 #RT's system user is a genuine database user. its id lives here
554 require RT::CurrentUser;
555 $SystemUser = RT::CurrentUser->new;
556 $SystemUser->LoadByName('RT_System');
558 #RT's "nobody user" is a genuine database user. its ID lives here.
559 $Nobody = RT::CurrentUser->new;
560 $Nobody->LoadByName('Nobody');
563 $System = RT::System->new( $SystemUser );
570 Returns the current L<config object|RT::Config>, but note that
571 you must L<load config|/LoadConfig> first otherwise this method
574 Method can be called as class method.
578 sub Config { return $Config || shift->LoadConfig(); }
580 =head2 DatabaseHandle
582 Returns the current L<database handle object|RT::Handle>.
584 See also L</ConnectToDatabase>.
588 sub DatabaseHandle { return $Handle }
592 Returns the logger. See also L</InitLogging>.
596 sub Logger { return $Logger }
600 Returns the current L<system object|RT::System>. See also
601 L</InitSystemObjects>.
605 sub System { return $System }
609 Returns the system user's object, it's object of
610 L<RT::CurrentUser> class that represents the system. See also
611 L</InitSystemObjects>.
615 sub SystemUser { return $SystemUser }
619 Returns object of Nobody. It's object of L<RT::CurrentUser> class
620 that represents a user who can own ticket and nothing else. See
621 also L</InitSystemObjects>.
625 sub Nobody { return $Nobody }
627 sub PrivilegedUsers {
629 $_Privileged = RT::Group->new(RT->SystemUser);
630 $_Privileged->LoadSystemInternalGroup('Privileged');
635 sub UnprivilegedUsers {
636 if (!$_Unprivileged) {
637 $_Unprivileged = RT::Group->new(RT->SystemUser);
638 $_Unprivileged->LoadSystemInternalGroup('Unprivileged');
640 return $_Unprivileged;
646 Returns a listref of all Plugins currently configured for this RT instance.
647 You can define plugins by adding them to the @Plugins list in your RT_SiteConfig
657 $self->InitPluginPaths;
658 @PLUGINS = $self->InitPlugins;
666 Takes an optional subdir (e.g. po, lib, etc.) and returns a list of
667 directories from plugins where that subdirectory exists.
669 This code does not check plugin names, plugin validitity, or load
670 plugins (see L</InitPlugins>) in any way, and requires that RT's
671 configuration have been already loaded.
682 foreach my $plugin (grep $_, RT->Config->Get('Plugins')) {
683 my $path = RT::Plugin->new( name => $plugin )->Path( $subdir );
684 next unless -d $path;
690 =head2 InitPluginPaths
692 Push plugins' lib paths into @INC right after F<local/lib>.
693 In case F<local/lib> isn't in @INC, append them to @INC
697 sub InitPluginPaths {
698 my $self = shift || __PACKAGE__;
700 my @lib_dirs = $self->PluginDirs('lib');
705 if ( Cwd::realpath($_) eq $RT::LocalLibPath) {
706 push @tmp_inc, $_, @lib_dirs;
713 # append @lib_dirs in case $RT::LocalLibPath isn't in @INC
714 push @tmp_inc, @lib_dirs unless $added;
717 @INC = grep !$seen{$_}++, @tmp_inc;
722 Initialize all Plugins found in the RT configuration file, setting up
723 their lib and L<HTML::Mason> component roots.
731 foreach my $plugin (grep $_, RT->Config->Get('Plugins')) {
733 die $UNIVERSAL::require::ERROR if ($UNIVERSAL::require::ERROR);
734 push @plugins, RT::Plugin->new(name =>$plugin);
743 my ($integrity, $state, $msg) = RT::Handle->CheckIntegrity;
744 if ($_[0] and $integrity) {
745 # Trying to turn install mode on but we have a good DB!
748 Carp::longmess("Something tried to turn on InstallMode but we have DB integrity!")
752 $_INSTALL_MODE = shift;
754 require RT::CurrentUser;
755 $SystemUser = RT::CurrentUser->new();
759 return $_INSTALL_MODE;
762 sub LoadGeneratedData {
764 my $pm_path = ( File::Spec->splitpath( $INC{'RT.pm'} ) )[1];
766 require "$pm_path/RT/Generated.pm" || die "Couldn't load RT::Generated: $@";
767 $class->CanonicalizeGeneratedPaths();
770 sub CanonicalizeGeneratedPaths {
772 unless ( File::Spec->file_name_is_absolute($EtcPath) ) {
774 # if BasePath exists and is absolute, we won't infer it from $INC{'RT.pm'}.
775 # otherwise RT.pm will make the source dir(where we configure RT) be the
776 # BasePath instead of the one specified by --prefix
777 unless ( -d $BasePath
778 && File::Spec->file_name_is_absolute($BasePath) )
780 my $pm_path = ( File::Spec->splitpath( $INC{'RT.pm'} ) )[1];
782 # need rel2abs here is to make sure path is absolute, since $INC{'RT.pm'}
783 # is not always absolute
784 $BasePath = File::Spec->rel2abs(
785 File::Spec->catdir( $pm_path, File::Spec->updir ) );
788 $BasePath = Cwd::realpath($BasePath);
791 qw/EtcPath BinPath SbinPath VarPath LocalPath StaticPath LocalEtcPath
792 LocalLibPath LexiconPath LocalLexiconPath PluginPath
793 LocalPluginPath LocalStaticPath MasonComponentRoot MasonLocalComponentRoot
794 MasonDataDir MasonSessionDir/
799 # just change relative ones
800 $$path = File::Spec->catfile( $BasePath, $$path )
801 unless File::Spec->file_name_is_absolute($$path);
809 Helper method to add JS files to the C<@JSFiles> config at runtime.
811 To add files, you can add the following line to your extension's main C<.pm>
814 RT->AddJavaScript( 'foo.js', 'bar.js' );
816 Files are expected to be in a static root in a F<js/> directory, such as
817 F<static/js/> in your extension or F<local/static/js/> for local overlays.
824 my @old = RT->Config->Get('JSFiles');
825 RT->Config->Set( 'JSFiles', @old, @_ );
826 return RT->Config->Get('JSFiles');
829 =head2 AddStyleSheets
831 Helper method to add CSS files to the C<@CSSFiles> config at runtime.
833 To add files, you can add the following line to your extension's main C<.pm>
836 RT->AddStyleSheets( 'foo.css', 'bar.css' );
838 Files are expected to be in a static root in a F<css/> directory, such as
839 F<static/css/> in your extension or F<local/static/css/> for local
846 my @old = RT->Config->Get('CSSFiles');
847 RT->Config->Set( 'CSSFiles', @old, @_ );
848 return RT->Config->Get('CSSFiles');
853 helper method of RT->Config->Get('JSFiles')
858 return RT->Config->Get('JSFiles');
863 helper method of RT->Config->Get('CSSFiles')
868 return RT->Config->Get('CSSFiles');
873 Notes that a particular call path is deprecated, and will be removed in
874 a particular release. Puts a warning in the logs indicating such, along
877 Optional arguments include:
883 The release which is slated to remove the method or component
887 A suggestion of what to use in place of the deprecated API
891 Used if not the entire method is being removed, merely a manner of
892 calling it; names the arguments which are deprecated.
896 Overrides the auto-built phrasing of C<Calling function ____ is
897 deprecated> with a custom message.
901 An L<RT::Record> object to print the class and numeric id of. Useful if the
902 admin will need to hunt down a particular object to fix the deprecation
920 my ($function) = (caller(1))[3];
922 if ($function eq "HTML::Mason::Commands::__ANON__") {
923 eval { HTML::Mason::Exception->throw() };
925 my $info = $error->analyze_error;
926 $function = "Mason component ".$info->{frames}[0]->filename;
927 $stack = join("\n", map { sprintf("\t[%s:%d]", $_->filename, $_->line) } @{$info->{frames}});
929 $function = "function $function";
930 $stack = Carp::longmess();
932 $stack =~ s/^.*?\n//; # Strip off call to ->Deprecated
935 if ($args{Message}) {
936 $msg = $args{Message};
937 } elsif ($args{Arguments}) {
938 $msg = "Calling $function with $args{Arguments} is deprecated";
940 $msg = "The $function is deprecated";
942 $msg .= ", and will be removed in RT $args{Remove}"
946 $msg .= " You should use $args{Instead} instead."
949 $msg .= sprintf " Object: %s #%d.", blessed($args{Object}), $args{Object}->id
952 $msg .= " Call stack:\n$stack" if $args{Stack};
953 RT->Logger->warn($msg);
958 Please report them to rt-bugs@bestpractical.com, if you know what's
959 broken and have at least some idea of what needs to be fixed.
961 If you're not sure what's going on, report them rt-devel@lists.bestpractical.com.
966 L<DBIx::SearchBuilder>
971 RT::Base->_ImportOverlays();