rt/lib/RT/Config.pm

   1 # BEGIN BPS TAGGED BLOCK {{{
   2 #
   3 # COPYRIGHT:
   4 #
   5 # This software is Copyright (c) 1996-2009 Best Practical Solutions, LLC
   6 #                                          <jesse@bestpractical.com>
   7 #
   8 # (Except where explicitly superseded by other copyright notices)
   9 #
  10 #
  11 # LICENSE:
  12 #
  13 # This work is made available to you under the terms of Version 2 of
  14 # the GNU General Public License. A copy of that license should have
  15 # been provided with this software, but in any event can be snarfed
  16 # from www.gnu.org.
  17 #
  18 # This work is distributed in the hope that it will be useful, but
  19 # WITHOUT ANY WARRANTY; without even the implied warranty of
  20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  21 # General Public License for more details.
  22 #
  23 # You should have received a copy of the GNU General Public License
  24 # along with this program; if not, write to the Free Software
  25 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  26 # 02110-1301 or visit their web page on the internet at
  27 # http://www.gnu.org/licenses/old-licenses/gpl-2.0.html.
  28 #
  29 #
  30 # CONTRIBUTION SUBMISSION POLICY:
  31 #
  32 # (The following paragraph is not intended to limit the rights granted
  33 # to you to modify and distribute this software under the terms of
  34 # the GNU General Public License and is only of importance to you if
  35 # you choose to contribute your changes and enhancements to the
  36 # community by submitting them to Best Practical Solutions, LLC.)
  37 #
  38 # By intentionally submitting any modifications, corrections or
  39 # derivatives to this work, or any other work intended for use with
  40 # Request Tracker, to Best Practical Solutions, LLC, you confirm that
  41 # you are the copyright holder for those contributions and you grant
  42 # Best Practical Solutions,  LLC a nonexclusive, worldwide, irrevocable,
  43 # royalty-free, perpetual, license to use, copy, create derivative
  44 # works based on those contributions, and sublicense and distribute
  45 # those contributions and any derivatives thereof.
  46 #
  47 # END BPS TAGGED BLOCK }}}
  48
  49 package RT::Config;
  50
  51 use strict;
  52 use warnings;
  53
  54 use File::Spec ();
  55
  56 =head1 NAME
  57
  58     RT::Config - RT's config
  59
  60 =head1 SYNOPSYS
  61
  62     # get config object
  63     use RT::Config;
  64     my $config = new RT::Config;
  65     $config->LoadConfigs;
  66
  67     # get or set option
  68     my $rt_web_path = $config->Get('WebPath');
  69     $config->Set(EmailOutputEncoding => 'latin1');
  70
  71     # get config object from RT package
  72     use RT;
  73     RT->LoadConfig;
  74     my $config = RT->Config;
  75
  76 =head1 DESCRIPTION
  77
  78 C<RT::Config> class provide access to RT's and RT extensions' config files.
  79
  80 RT uses two files for site configuring:
  81
  82 First file is F<RT_Config.pm> - core config file. This file is shipped
  83 with RT distribution and contains default values for all available options.
  84 B<You should never edit this file.>
  85
  86 Second file is F<RT_SiteConfig.pm> - site config file. You can use it
  87 to customize your RT instance. In this file you can override any option
  88 listed in core config file.
  89
  90 RT extensions could also provide thier config files. Extensions should
  91 use F<< <NAME>_Config.pm >> and F<< <NAME>_SiteConfig.pm >> names for
  92 config files, where <NAME> is extension name.
  93
  94 B<NOTE>: All options from RT's config and extensions' configs are saved
  95 in one place and thus extension could override RT's options, but it is not
  96 recommended.
  97
  98 =cut
  99
 100 =head2 %META
 101
 102 Hash of Config options that may be user overridable
 103 or may require more logic than should live in RT_*Config.pm
 104
 105 Keyed by config name, there are several properties that
 106 can be set for each config optin:
 107
 108  Section     - What header this option should be grouped
 109                under on the user Settings page
 110  Overridable - Can users change this option
 111  SortOrder   - Within a Section, how should the options be sorted
 112                for display to the user
 113  Widget      - Mason component path to widget that should be used
 114                to display this config option
 115  WidgetArguments - An argument hash passed to the WIdget
 116     Description - Friendly description to show the user
 117     Values      - Arrayref of options (for select Widget)
 118     ValuesLabel - Hashref, key is the Value from the Values
 119                   list, value is a user friendly description
 120                   of the value
 121     Callback    - subref that receives no arguments.  It returns
 122                   a hashref of items that are added to the rest
 123                   of the WidgetArguments
 124  PostLoadCheck - subref passed the RT::Config object and the current
 125                  setting of the config option.  Can make further checks
 126                  (such as seeing if a library is installed) and then change
 127                  the setting of this or other options in the Config using
 128                  the RT::Config option.
 129
 130 =cut
 131
 132 our %META = (
 133     # General user overridable options
 134     DefaultQueue => {
 135         Section         => 'General',
 136         Overridable     => 1,
 137         SortOrder       => 1,
 138         Widget          => '/Widgets/Form/Select',
 139         WidgetArguments => {
 140             Description => 'Default queue',    #loc
 141             Callback    => sub {
 142                 my $ret = { Values => [], ValuesLabel => {}};
 143                 my $q = new RT::Queues($HTML::Mason::Commands::session{'CurrentUser'});
 144                 $q->UnLimit;
 145                 while (my $queue = $q->Next) {
 146                     next unless $queue->CurrentUserHasRight("CreateTicket");
 147                     push @{$ret->{Values}}, $queue->Id;
 148                     $ret->{ValuesLabel}{$queue->Id} = $queue->Name;
 149                 }
 150                 return $ret;
 151             },
 152         }
 153     },
 154     UsernameFormat => {
 155         Section         => 'General',
 156         Overridable     => 1,
 157         SortOrder       => 2,
 158         Widget          => '/Widgets/Form/Select',
 159         WidgetArguments => {
 160             Description => 'Username format', # loc
 161             Values      => [qw(concise verbose)],
 162             ValuesLabel => {
 163                 concise => 'Short usernames', # loc_left_pair
 164                 verbose => 'Name and email address', # loc_left_pair
 165             },
 166         },
 167     },
 168     WebDefaultStylesheet => {
 169         Section         => 'General',                #loc
 170         Overridable     => 1,
 171         SortOrder       => 3,
 172         Widget          => '/Widgets/Form/Select',
 173         WidgetArguments => {
 174             Description => 'Theme',                  #loc
 175             # XXX: we need support for 'get values callback'
 176             Values => [qw(3.5-default 3.4-compat web2 freeside2.1)],
 177         },
 178     },
 179     MessageBoxRichText => {
 180         Section => 'General',
 181         Overridable => 1,
 182         SortOrder => 4,
 183         Widget => '/Widgets/Form/Boolean',
 184         WidgetArguments => {
 185             Description => 'WYSIWYG message composer' # loc
 186         }
 187     },
 188     MessageBoxRichTextHeight => {
 189         Section => 'General',
 190         Overridable => 1,
 191         SortOrder => 5,
 192         Widget => '/Widgets/Form/Integer',
 193         WidgetArguments => {
 194             Description => 'WYSIWYG composer height', # loc
 195         }
 196     },
 197     MessageBoxWidth => {
 198         Section         => 'General',
 199         Overridable     => 1,
 200         SortOrder       => 6,
 201         Widget          => '/Widgets/Form/Integer',
 202         WidgetArguments => {
 203             Description => 'Message box width',           #loc
 204         },
 205     },
 206     MessageBoxHeight => {
 207         Section         => 'General',
 208         Overridable     => 1,
 209         SortOrder       => 7,
 210         Widget          => '/Widgets/Form/Integer',
 211         WidgetArguments => {
 212             Description => 'Message box height',          #loc
 213         },
 214     },
 215     SearchResultsRefreshInterval => {
 216         Section         => 'General',                       #loc
 217         Overridable     => 1,
 218         SortOrder       => 8,
 219         Widget          => '/Widgets/Form/Select',
 220         WidgetArguments => {
 221             Description => 'Search results refresh interval',                            #loc
 222             Values      => [qw(0 120 300 600 1200 3600 7200)],
 223             ValuesLabel => {
 224                 0 => "Don't refresh search results.",                      #loc
 225                 120 => "Refresh search results every 2 minutes.",          #loc
 226                 300 => "Refresh search results every 5 minutes.",          #loc
 227                 600 => "Refresh search results every 10 minutes.",         #loc
 228                 1200 => "Refresh search results every 20 minutes.",        #loc
 229                 3600 => "Refresh search results every 60 minutes.",        #loc
 230                 7200 => "Refresh search results every 120 minutes.",       #loc
 231             },
 232         },
 233     },
 234
 235     # User overridable options for RT at a glance
 236     DefaultSummaryRows => {
 237         Section         => 'RT at a glance',    #loc
 238         Overridable     => 1,
 239         SortOrder       => 1,
 240         Widget          => '/Widgets/Form/Integer',
 241         WidgetArguments => {
 242             Description => 'Number of search results',    #loc
 243         },
 244     },
 245     HomePageRefreshInterval => {
 246         Section         => 'RT at a glance',                       #loc
 247         Overridable     => 1,
 248         SortOrder       => 2,
 249         Widget          => '/Widgets/Form/Select',
 250         WidgetArguments => {
 251             Description => 'Home page refresh interval',                #loc
 252             Values      => [qw(0 120 300 600 1200 3600 7200)],
 253             ValuesLabel => {
 254                 0 => "Don't refresh home page.",                  #loc
 255                 120 => "Refresh home page every 2 minutes.",      #loc
 256                 300 => "Refresh home page every 5 minutes.",      #loc
 257                 600 => "Refresh home page every 10 minutes.",     #loc
 258                 1200 => "Refresh home page every 20 minutes.",    #loc
 259                 3600 => "Refresh home page every 60 minutes.",    #loc
 260                 7200 => "Refresh home page every 120 minutes.",   #loc
 261             },
 262         },
 263     },
 264
 265     # User overridable options for Ticket displays
 266     MaxInlineBody => {
 267         Section         => 'Ticket display',              #loc
 268         Overridable     => 1,
 269         SortOrder       => 1,
 270         Widget          => '/Widgets/Form/Integer',
 271         WidgetArguments => {
 272             Description => 'Maximum inline message length',    #loc
 273             Hints =>
 274             "Length in characters; Use '0' to show all messages inline, regardless of length" #loc
 275         },
 276     },
 277     OldestTransactionsFirst => {
 278         Section         => 'Ticket display',
 279         Overridable     => 1,
 280         SortOrder       => 2,
 281         Widget          => '/Widgets/Form/Boolean',
 282         WidgetArguments => {
 283             Description => 'Show oldest history first',    #loc
 284         },
 285     },
 286     ShowUnreadMessageNotifications => {
 287         Section         => 'Ticket display',
 288         Overridable     => 1,
 289         SortOrder       => 3,
 290         Widget          => '/Widgets/Form/Boolean',
 291         WidgetArguments => {
 292             Description => 'Notify me of unread messages',    #loc
 293         },
 294
 295     },
 296     PlainTextPre => {
 297         Section         => 'Ticket display',
 298         Overridable     => 1,
 299         SortOrder       => 4,
 300         Widget          => '/Widgets/Form/Boolean',
 301         WidgetArguments => {
 302             Description => 'add <pre> tag around plain text attachments', #loc
 303             Hints       => "Use this to protect the format of plain text" #loc
 304         },
 305     },
 306     PlainTextMono => {
 307         Section         => 'Ticket display',
 308         Overridable     => 1,
 309         SortOrder       => 5,
 310         Widget          => '/Widgets/Form/Boolean',
 311         WidgetArguments => {
 312             Description => 'display wrapped and formatted plain text attachments', #loc
 313             Hints => 'Use css rules to display text monospaced and with formatting preserved, but wrap as needed.  This does not work well with IE6 and you should use the previous option', #loc
 314         },
 315     },
 316
 317     # User overridable locale options
 318     DateTimeFormat => {
 319         Section         => 'Locale',                       #loc
 320         Overridable     => 1,
 321         Widget          => '/Widgets/Form/Select',
 322         WidgetArguments => {
 323             Description => 'Date format',                            #loc
 324             Callback => sub { my $ret = { Values => [], ValuesLabel => {}};
 325                               my $date = new RT::Date($HTML::Mason::Commands::session{'CurrentUser'});
 326                               $date->Set;
 327                               foreach my $value ($date->Formatters) {
 328                                  push @{$ret->{Values}}, $value;
 329                                  $ret->{ValuesLabel}{$value} = $date->$value();
 330                               }
 331                               return $ret;
 332             },
 333         },
 334     },
 335
 336     # User overridable mail options
 337     EmailFrequency => {
 338         Section         => 'Mail',                                     #loc
 339         Overridable     => 1,
 340         Default     => 'Individual messages',
 341         Widget          => '/Widgets/Form/Select',
 342         WidgetArguments => {
 343             Description => 'Email delivery',    #loc
 344             Values      => [
 345             'Individual messages',    #loc
 346             'Daily digest',           #loc
 347             'Weekly digest',          #loc
 348             'Suspended'               #loc
 349             ]
 350         }
 351     },
 352
 353     # this tends to break extensions that stash links in ticket update pages
 354     Organization => {
 355         Type            => 'SCALAR',
 356         PostLoadCheck   => sub {
 357             my ($self,$value) = @_;
 358             $RT::Logger->error("your \$Organization setting ($value) appears to contain whitespace.  Please fix this.")
 359                 if $value =~ /\s/;;
 360         },
 361     },
 362
 363     # Internal config options
 364     DisableGraphViz => {
 365         Type            => 'SCALAR',
 366         PostLoadCheck   => sub {
 367             my $self  = shift;
 368             my $value = shift;
 369             return if $value;
 370             return if $INC{'GraphViz.pm'};
 371             local $@;
 372             return if eval {require GraphViz; 1};
 373             $RT::Logger->debug("You've enabled GraphViz, but we couldn't load the module: $@");
 374             $self->Set( DisableGraphViz => 1 );
 375         },
 376     },
 377     DisableGD => {
 378         Type            => 'SCALAR',
 379         PostLoadCheck   => sub {
 380             my $self  = shift;
 381             my $value = shift;
 382             return if $value;
 383             return if $INC{'GD.pm'};
 384             local $@;
 385             return if eval {require GD; 1};
 386             $RT::Logger->debug("You've enabled GD, but we couldn't load the module: $@");
 387             $self->Set( DisableGD => 1 );
 388         },
 389     },
 390     MailPlugins  => { Type => 'ARRAY' },
 391     Plugins      => { Type => 'ARRAY' },
 392     GnuPG        => { Type => 'HASH' },
 393     GnuPGOptions => { Type => 'HASH',
 394         PostLoadCheck => sub {
 395             my $self = shift;
 396             my $gpg = $self->Get('GnuPG');
 397             return unless $gpg->{'Enable'};
 398             my $gpgopts = $self->Get('GnuPGOptions');
 399             unless (-d $gpgopts->{homedir}  && -r _ ) { # no homedir, no gpg
 400                 $RT::Logger->debug(
 401                     "RT's GnuPG libraries couldn't successfully read your".
 402                     " configured GnuPG home directory (".$gpgopts->{homedir}
 403                     ."). PGP support has been disabled");
 404                 $gpg->{'Enable'} = 0;
 405                 return;
 406             }
 407
 408
 409             require RT::Crypt::GnuPG;
 410             unless (RT::Crypt::GnuPG->Probe()) {
 411                 $RT::Logger->debug(
 412                     "RT's GnuPG libraries couldn't successfully execute gpg.".
 413                     " PGP support has been disabled");
 414                 $gpg->{'Enable'} = 0;
 415             }
 416         }
 417     },
 418 );
 419 my %OPTIONS = ();
 420
 421 =head1 METHODS
 422
 423 =head2 new
 424
 425 Object constructor returns new object. Takes no arguments.
 426
 427 =cut
 428
 429 sub new {
 430     my $proto = shift;
 431     my $class = ref($proto) ? ref($proto) : $proto;
 432     my $self  = bless {}, $class;
 433     $self->_Init(@_);
 434     return $self;
 435 }
 436
 437 sub _Init {
 438     return;
 439 }
 440
 441 =head2 InitConfig
 442
 443 Do nothin right now.
 444
 445 =cut
 446
 447 sub InitConfig {
 448     my $self = shift;
 449     my %args = ( File => '', @_ );
 450     $args{'File'} =~ s/(?<=Config)(?=\.pm$)/Meta/;
 451     return 1;
 452 }
 453
 454 =head2 LoadConfigs
 455
 456 Load all configs. First of all load RT's config then load
 457 extensions' config files in alphabetical order.
 458 Takes no arguments.
 459
 460 =cut
 461
 462 sub LoadConfigs {
 463     my $self    = shift;
 464
 465     $self->InitConfig( File => 'RT_Config.pm' );
 466     $self->LoadConfig( File => 'RT_Config.pm' );
 467
 468     my @configs = $self->Configs;
 469     $self->InitConfig( File => $_ ) foreach @configs;
 470     $self->LoadConfig( File => $_ ) foreach @configs;
 471     return;
 472 }
 473
 474 =head1 LoadConfig
 475
 476 Takes param hash with C<File> field.
 477 First, the site configuration file is loaded, in order to establish
 478 overall site settings like hostname and name of RT instance.
 479 Then, the core configuration file is loaded to set fallback values
 480 for all settings; it bases some values on settings from the site
 481 configuration file.
 482
 483 B<Note> that core config file don't change options if site config
 484 has set them so to add value to some option instead of
 485 overriding you have to copy original value from core config file.
 486
 487 =cut
 488
 489 sub LoadConfig {
 490     my $self = shift;
 491     my %args = ( File => '', @_ );
 492     $args{'File'} =~ s/(?<!Site)(?=Config\.pm$)/Site/;
 493     if ( $args{'File'} eq 'RT_SiteConfig.pm'
 494         and my $site_config = $ENV{RT_SITE_CONFIG} )
 495     {
 496         $self->_LoadConfig( %args, File => $site_config );
 497     } else {
 498         $self->_LoadConfig(%args);
 499     }
 500     $args{'File'} =~ s/Site(?=Config\.pm$)//;
 501     $self->_LoadConfig(%args);
 502     return 1;
 503 }
 504
 505 sub _LoadConfig {
 506     my $self = shift;
 507     my %args = ( File => '', @_ );
 508
 509     my ($is_ext, $is_site);
 510     if ( $args{'File'} eq ($ENV{RT_SITE_CONFIG}||'') ) {
 511         ($is_ext, $is_site) = ('', 1);
 512     } else {
 513         $is_ext = $args{'File'} =~ /^(?!RT_)(?:(.*)_)(?:Site)?Config/ ? $1 : '';
 514         $is_site = $args{'File'} =~ /SiteConfig/ ? 1 : 0;
 515     }
 516
 517     eval {
 518         package RT;
 519         local *Set = sub(\[$@%]@) {
 520             my ( $opt_ref, @args ) = @_;
 521             my ( $pack, $file, $line ) = caller;
 522             return $self->SetFromConfig(
 523                 Option     => $opt_ref,
 524                 Value      => [@args],
 525                 Package    => $pack,
 526                 File       => $file,
 527                 Line       => $line,
 528                 SiteConfig => $is_site,
 529                 Extension  => $is_ext,
 530             );
 531         };
 532         my @etc_dirs = ($RT::LocalEtcPath);
 533         push @etc_dirs, RT->PluginDirs('etc') if $is_ext;
 534         push @etc_dirs, $RT::EtcPath, @INC;
 535         local @INC = @etc_dirs;
 536         require $args{'File'};
 537     };
 538     if ($@) {
 539         return 1 if $is_site && $@ =~ qr{^Can't locate \Q$args{File}};
 540         if ( $is_site || $@ !~ qr{^Can't locate \Q$args{File}} ) {
 541             die qq{Couldn't load RT config file $args{'File'}:\n\n$@};
 542         }
 543
 544         my $username = getpwuid($>);
 545         my $group    = getgrgid($();
 546
 547         my ( $file_path, $fileuid, $filegid );
 548         foreach ( $RT::LocalEtcPath, $RT::EtcPath, @INC ) {
 549             my $tmp = File::Spec->catfile( $_, $args{File} );
 550             ( $fileuid, $filegid ) = ( stat($tmp) )[ 4, 5 ];
 551             if ( defined $fileuid ) {
 552                 $file_path = $tmp;
 553                 last;
 554             }
 555         }
 556         unless ($file_path) {
 557             die
 558                 qq{Couldn't load RT config file $args{'File'} as user $username / group $group.\n}
 559                 . qq{The file couldn't be found in $RT::LocalEtcPath and $RT::EtcPath.\n$@};
 560         }
 561
 562         my $message = <<EOF;
 563
 564 RT couldn't load RT config file %s as:
 565     user: $username
 566     group: $group
 567
 568 The file is owned by user %s and group %s.
 569
 570 This usually means that the user/group your webserver is running
 571 as cannot read the file.  Be careful not to make the permissions
 572 on this file too liberal, because it contains database passwords.
 573 You may need to put the webserver user in the appropriate group
 574 (%s) or change permissions be able to run succesfully.
 575 EOF
 576
 577         my $fileusername = getpwuid($fileuid);
 578         my $filegroup    = getgrgid($filegid);
 579         my $errormessage = sprintf( $message,
 580             $file_path, $fileusername, $filegroup, $filegroup );
 581         die "$errormessage\n$@";
 582     }
 583     return 1;
 584 }
 585
 586 sub PostLoadCheck {
 587     my $self = shift;
 588     foreach my $o ( grep $META{$_}{'PostLoadCheck'}, $self->Options( Overridable => undef ) ) {
 589         $META{$o}->{'PostLoadCheck'}->( $self, $self->Get($o) );
 590     }
 591 }
 592
 593 =head2 Configs
 594
 595 Returns list of config files found in local etc, plugins' etc
 596 and main etc directories.
 597
 598 =cut
 599
 600 sub Configs {
 601     my $self    = shift;
 602
 603     my @configs = ();
 604     foreach my $path ( $RT::LocalEtcPath, RT->PluginDirs('etc'), $RT::EtcPath ) {
 605         my $mask = File::Spec->catfile( $path, "*_Config.pm" );
 606         my @files = glob $mask;
 607         @files = grep !/^RT_Config\.pm$/,
 608             grep $_ && /^\w+_Config\.pm$/,
 609             map { s/^.*[\\\/]//; $_ } @files;
 610         push @configs, sort @files;
 611     }
 612
 613     my %seen;
 614     @configs = grep !$seen{$_}++, @configs;
 615     return @configs;
 616 }
 617
 618 =head2 Get
 619
 620 Takes name of the option as argument and returns its current value.
 621
 622 In the case of a user-overridable option, first checks the user's
 623 preferences before looking for site-wide configuration.
 624
 625 Returns values from RT_SiteConfig, RT_Config and then the %META hash
 626 of configuration variables's "Default" for this config variable,
 627 in that order.
 628
 629 Returns different things in scalar and array contexts. For scalar
 630 options it's not that important, however for arrays and hash it's.
 631 In scalar context returns references to arrays and hashes.
 632
 633 Use C<scalar> perl's op to force context, especially when you use
 634 C<(..., Argument => RT->Config->Get('ArrayOpt'), ...)>
 635 as perl's '=>' op doesn't change context of the right hand argument to
 636 scalar. Instead use C<(..., Argument => scalar RT->Config->Get('ArrayOpt'), ...)>.
 637
 638 It's also important for options that have no default value(no default
 639 in F<etc/RT_Config.pm>). If you don't force scalar context then you'll
 640 get empty list and all your named args will be messed up. For example
 641 C<(arg1 => 1, arg2 => RT->Config->Get('OptionDoesNotExist'), arg3 => 3)>
 642 will result in C<(arg1 => 1, arg2 => 'arg3', 3)> what is most probably
 643 unexpected, or C<(arg1 => 1, arg2 => RT->Config->Get('ArrayOption'), arg3 => 3)>
 644 will result in C<(arg1 => 1, arg2 => 'element of option', 'another_one' => ..., 'arg3', 3)>.
 645
 646 =cut
 647
 648 sub Get {
 649     my ( $self, $name, $user ) = @_;
 650
 651     my $res;
 652     if ( $user && $user->id && $META{$name}->{'Overridable'} ) {
 653         $user = $user->UserObj if $user->isa('RT::CurrentUser');
 654         my $prefs = $user->Preferences($RT::System);
 655         $res = $prefs->{$name} if $prefs;
 656     }
 657     $res = $OPTIONS{$name}           unless defined $res;
 658     $res = $META{$name}->{'Default'} unless defined $res;
 659     return $self->_ReturnValue( $res, $META{$name}->{'Type'} || 'SCALAR' );
 660 }
 661
 662 =head2 Set
 663
 664 Set option's value to new value. Takes name of the option and new value.
 665 Returns old value.
 666
 667 The new value should be scalar, array or hash depending on type of the option.
 668 If the option is not defined in meta or the default RT config then it is of
 669 scalar type.
 670
 671 =cut
 672
 673 sub Set {
 674     my ( $self, $name ) = ( shift, shift );
 675
 676     my $old = $OPTIONS{$name};
 677     my $type = $META{$name}->{'Type'} || 'SCALAR';
 678     if ( $type eq 'ARRAY' ) {
 679         $OPTIONS{$name} = [@_];
 680         { no warnings 'once'; no strict 'refs'; @{"RT::$name"} = (@_); }
 681     } elsif ( $type eq 'HASH' ) {
 682         $OPTIONS{$name} = {@_};
 683         { no warnings 'once'; no strict 'refs'; %{"RT::$name"} = (@_); }
 684     } else {
 685         $OPTIONS{$name} = shift;
 686         {no warnings 'once'; no strict 'refs'; ${"RT::$name"} = $OPTIONS{$name}; }
 687     }
 688     $META{$name}->{'Type'} = $type;
 689     return $self->_ReturnValue( $old, $type );
 690 }
 691
 692 sub _ReturnValue {
 693     my ( $self, $res, $type ) = @_;
 694     return $res unless wantarray;
 695
 696     if ( $type eq 'ARRAY' ) {
 697         return @{ $res || [] };
 698     } elsif ( $type eq 'HASH' ) {
 699         return %{ $res || {} };
 700     }
 701     return $res;
 702 }
 703
 704 sub SetFromConfig {
 705     my $self = shift;
 706     my %args = (
 707         Option     => undef,
 708         Value      => [],
 709         Package    => 'RT',
 710         File       => '',
 711         Line       => 0,
 712         SiteConfig => 1,
 713         Extension  => 0,
 714         @_
 715     );
 716
 717     unless ( $args{'File'} ) {
 718         ( $args{'Package'}, $args{'File'}, $args{'Line'} ) = caller(1);
 719     }
 720
 721     my $opt = $args{'Option'};
 722
 723     my $type;
 724     my $name = $self->__GetNameByRef($opt);
 725     if ($name) {
 726         $type = ref $opt;
 727         $name =~ s/.*:://;
 728     } else {
 729         $name = $$opt;
 730         $type = $META{$name}->{'Type'} || 'SCALAR';
 731     }
 732
 733     # if option is already set we have to check where
 734     # it comes from and may be ignore it
 735     if ( exists $OPTIONS{$name} ) {
 736         if ( $args{'SiteConfig'} && $args{'Extension'} ) {
 737             # if it's site config of an extension then it can only
 738             # override options that came from its main config
 739             if ( $args{'Extension'} ne $META{$name}->{'Source'}{'Extension'} ) {
 740                 my %source = %{ $META{$name}->{'Source'} };
 741                 warn
 742                     "Change of config option '$name' at $args{'File'} line $args{'Line'} has been ignored."
 743                     ." This option earlier has been set in $source{'File'} line $source{'Line'}."
 744                     ." To overide this option use ". ($source{'Extension'}||'RT')
 745                     ." site config."
 746                 ;
 747                 return 1;
 748             }
 749         } elsif ( !$args{'SiteConfig'} && $META{$name}->{'Source'}{'SiteConfig'} ) {
 750             # if it's core config then we can override any option that came from another
 751             # core config, but not site config
 752
 753             my %source = %{ $META{$name}->{'Source'} };
 754             if ( $source{'Extension'} ne $args{'Extension'} ) {
 755                 # as a site config is loaded earlier then its base config
 756                 # then we warn only on different extensions, for example
 757                 # RTIR's options is set in main site config or RTFM's
 758                 warn
 759                     "Change of config option '$name' at $args{'File'} line $args{'Line'} has been ignored."
 760                     ." It's may be ok, but we want you to be aware."
 761                     ." This option earlier has been set in $source{'File'} line $source{'Line'}."
 762                 ;
 763             }
 764
 765             return 1;
 766         }
 767     }
 768
 769     $META{$name}->{'Type'} = $type;
 770     foreach (qw(Package File Line SiteConfig Extension)) {
 771         $META{$name}->{'Source'}->{$_} = $args{$_};
 772     }
 773     $self->Set( $name, @{ $args{'Value'} } );
 774
 775     return 1;
 776 }
 777
 778 {
 779     my $last_pack = '';
 780
 781     sub __GetNameByRef {
 782         my $self = shift;
 783         my $ref  = shift;
 784         my $pack = shift;
 785         if ( !$pack && $last_pack ) {
 786             my $tmp = $self->__GetNameByRef( $ref, $last_pack );
 787             return $tmp if $tmp;
 788         }
 789         $pack ||= 'main::';
 790         $pack .= '::' unless substr( $pack, -2 ) eq '::';
 791
 792         my %ref_sym = (
 793             SCALAR => '$',
 794             ARRAY  => '@',
 795             HASH   => '%',
 796             CODE   => '&',
 797         );
 798         no strict 'refs';
 799         my $name = undef;
 800
 801         # scan $pack's nametable(hash)
 802         foreach my $k ( keys %{$pack} ) {
 803
 804             # hash for main:: has reference on itself
 805             next if $k eq 'main::';
 806
 807             # if entry has trailing '::' then
 808             # it is link to other name space
 809             if ( $k =~ /::$/ ) {
 810                 $name = $self->__GetNameByRef( $ref, $k );
 811                 return $name if $name;
 812             }
 813
 814             # entry of the table with references to
 815             # SCALAR, ARRAY... and other types with
 816             # the same name
 817             my $entry = ${$pack}{$k};
 818             next unless $entry;
 819
 820             # get entry for type we are looking for
 821             # XXX skip references to scalars or other references.
 822             # Otherwie 5.10 goes boom. may be we should skip any
 823             # reference
 824             return if ref($entry) eq 'SCALAR' || ref($entry) eq 'REF';
 825             my $entry_ref = *{$entry}{ ref($ref) };
 826             next unless $entry_ref;
 827
 828             # if references are equal then we've found
 829             if ( $entry_ref == $ref ) {
 830                 $last_pack = $pack;
 831                 return ( $ref_sym{ ref($ref) } || '*' ) . $pack . $k;
 832             }
 833         }
 834         return '';
 835     }
 836 }
 837
 838 =head2 Metadata
 839
 840
 841 =head2 Meta
 842
 843 =cut
 844
 845 sub Meta {
 846     return $META{ $_[1] };
 847 }
 848
 849 sub Sections {
 850     my $self = shift;
 851     my %seen;
 852     return sort
 853         grep !$seen{$_}++,
 854         map $_->{'Section'} || 'General',
 855         values %META;
 856 }
 857
 858 sub Options {
 859     my $self = shift;
 860     my %args = ( Section => undef, Overridable => 1, Sorted => 1, @_ );
 861     my @res  = keys %META;
 862
 863     @res = grep( ( $META{$_}->{'Section'} || 'General' ) eq $args{'Section'},
 864         @res
 865     ) if defined $args{'Section'};
 866
 867     if ( defined $args{'Overridable'} ) {
 868         @res
 869             = grep( ( $META{$_}->{'Overridable'} || 0 ) == $args{'Overridable'},
 870             @res );
 871     }
 872
 873     if ( $args{'Sorted'} ) {
 874         @res = sort {
 875             ($META{$a}->{SortOrder}||9999) <=> ($META{$b}->{SortOrder}||9999)
 876             || $a cmp $b
 877         } @res;
 878     } else {
 879         @res = sort { $a cmp $b } @res;
 880     }
 881     return @res;
 882 }
 883
 884 eval "require RT::Config_Vendor";
 885 if ($@ && $@ !~ qr{^Can't locate RT/Config_Vendor.pm}) {
 886     die $@;
 887 };
 888
 889 eval "require RT::Config_Local";
 890 if ($@ && $@ !~ qr{^Can't locate RT/Config_Local.pm}) {
 891     die $@;
 892 };
 893
 894 1;