root/branches/feature-no-make-me/lib/MT.pm @ 2702

Revision 2702, 106.2 kB (checked in by arvind, 17 months ago)

Initial work on eliminating the need to run make me:
* Moved language constants into MT::I18N frameork
* Replaced preprocessor directives with their I18N equivs or hardcode
* Removed the need for .pre files
* mt-wizard.cgi and mt-check.cgi now attempt to detect browser language using MT::Util::browser_language
Line 
1# Movable Type (r) Open Source (C) 2001-2008 Six Apart, Ltd.
2# This program is distributed under the terms of the
3# GNU General Public License, version 2.
4#
5# $Id: MT.pm.pre 2276 2008-05-08 16:52:18Z fumiakiy $
6
7package MT;
8
9use strict;
10use base qw( MT::ErrorHandler );
11use File::Spec;
12use File::Basename;
13use MT::Util qw( weaken );
14use MT::I18N qw( encode_text );
15
16our ( $VERSION,      $SCHEMA_VERSION );
17our ( $PRODUCT_NAME, $PRODUCT_CODE, $PRODUCT_VERSION, $VERSION_ID );
18our ( $MT_DIR,       $APP_DIR, $CFG_DIR, $CFG_FILE, $SCRIPT_SUFFIX );
19our (
20    $plugin_sig, $plugin_envelope, $plugin_registry,
21    %Plugins,    @Components,      %Components,
22    $DebugMode,  $mt_inst,         %mt_inst
23);
24my %Text_filters;
25
26# For state determination in MT::Object
27our $plugins_installed;
28
29BEGIN {
30    $plugins_installed = 0;
31
32    ( $VERSION, $SCHEMA_VERSION ) = ( '4.2', '4.0066' );
33    ( $PRODUCT_NAME, $PRODUCT_CODE, $PRODUCT_VERSION, $VERSION_ID ) = (
34        '__PRODUCT_NAME__', 'MT',
35        '4.2', '4.2'
36    );
37
38    # To allow MT to run straight from svn, if no build process (pre-processing)
39    # is run, then default to MTOS
40    if ($PRODUCT_NAME eq '__PRODUCT' . '_NAME__') {
41        $PRODUCT_NAME = 'Movable Type Open Source';
42    }
43
44    $DebugMode = 0;
45
46    # Alias lowercase to uppercase package; note: this is an equivalence
47    # as opposed to having @mt::ISA set to 'MT'. so @mt::Plugins would
48    # resolve as well as @MT::Plugins.
49    *{mt::} = *{MT::};
50
51    # Alias these; Components is the preferred array for MT 4
52    *Plugins = \@Components;
53}
54
55# On-demand loading of compatibility module, if a plugin asks for it, using
56#     use MT 3;
57# or even specific to minor version (but this just loads MT::Compat::v3)
58#     use MT 3.3;
59sub VERSION {
60    my $v = $_[1];
61    if ( defined $v && ( $v =~ m/^(\d+)/ ) ) {
62        my $compat = "MT::Compat::v" . $1;
63        if ( ( $1 > 2 ) && ( $1 < int($VERSION) ) ) {
64            no strict 'refs';
65            unless ( defined *{ $compat . '::' } ) {
66                eval "# line " . __LINE__ . " " . __FILE__ . "\nrequire $compat;";
67            }
68        }
69    }
70    return UNIVERSAL::VERSION(@_);
71}
72
73sub version_number  { $VERSION }
74sub version_id      { $VERSION_ID }
75sub product_code    { $PRODUCT_CODE }
76sub product_name    { $PRODUCT_NAME }
77sub product_version { $PRODUCT_VERSION }
78sub schema_version  { $SCHEMA_VERSION }
79
80# Default id method turns MT::App::CMS => cms; Foo::Bar => foo/bar
81sub id {
82    my $pkg = shift;
83    my $id = ref($pkg) || $pkg;
84    # ignore the MT::App prefix as part of the identifier
85    $id =~ s/^MT::App:://;
86    $id =~ s!::!/!g;
87    return lc $id;
88}
89
90sub version_slug {
91    return MT->translate_templatized(<<"SLUG");
92<MT_TRANS phrase="Powered by [_1]" params="$PRODUCT_NAME">
93<MT_TRANS phrase="Version [_1]" params="$VERSION_ID">
94<MT_TRANS phrase="http://www.sixapart.com/movabletype/">
95SLUG
96}
97
98sub import {
99    my $pkg = shift;
100    return unless @_;
101
102    my (%param) = @_;
103    my $app_pkg;
104    if ( $app_pkg = $param{app} || $param{App} || $ENV{MT_APP} ) {
105        if ( $app_pkg !~ m/::/ ) {
106            my $apps = $pkg->registry('applications');
107            $app_pkg = $apps->fetch($app_pkg);
108            if ( ref $app_pkg ) {
109
110                # pick first one??
111                $app_pkg = $app_pkg->[0];
112
113                # pick last one??
114                # $app_pkg = pop @$app_pkg;
115            }
116        }
117    }
118    elsif ( $param{run} || $param{Run} ) {
119
120        # my $script = File::Spec->rel2abs($0);
121        my ( $filename, $path, $suffix ) = fileparse( $0, qr{\..+$} );
122        $SCRIPT_SUFFIX = $suffix;
123        my $script = lc $filename;
124        $script =~ s/^mt-//;
125        my $apps = $pkg->registry('applications');
126        $app_pkg = $apps->fetch( lc $script );
127        unless ($app_pkg) {
128            die "cannot determine application for script $0, stopped at";
129        }
130    }
131    $pkg->run_app( $app_pkg, \%param )
132      if $app_pkg;
133}
134
135sub run_app {
136    my $pkg = shift;
137    my ( $class, $param ) = @_;
138
139    # When running under FastCGI, the initial invocation of the
140    # script has a bare environment. We can use this to test
141    # for FastCGI.
142    my $not_fast_cgi = 0;
143    $not_fast_cgi ||= exists $ENV{$_}
144      for qw(HTTP_HOST GATEWAY_INTERFACE SCRIPT_FILENAME SCRIPT_URL);
145    my $fast_cgi = ( !$not_fast_cgi ) || $param->{fastcgi};
146    $fast_cgi =
147      defined( $param->{fastcgi} || $param->{FastCGI} )
148      ? ( $param->{fastcgi} || $param->{FastCGI} )
149      : $fast_cgi;
150    if ($fast_cgi) {
151        eval { require CGI::Fast; };
152        $fast_cgi = 0 if $@;
153    }
154
155    # ready to run now... run inside an eval block so we can gracefully
156    # die if something bad happens
157    my $app;
158    eval {
159        eval "require $class; 1;" or die $@;
160        if ($fast_cgi) {
161            while ( my $cgi = new CGI::Fast ) {
162                $app = $class->new( %$param, CGIObject => $cgi )
163                  or die $class->errstr;
164                local $SIG{__WARN__} = sub { $app->trace( $_[0] ) };
165                $pkg->set_instance($app);
166                $app->init_request( CGIObject => $cgi );
167                $app->run;
168            }
169        }
170        else {
171            $app = $class->new(%$param) or die $class->errstr;
172            local $SIG{__WARN__} = sub { $app->trace( $_[0] ) };
173            $app->run;
174        }
175    };
176    if ( my $err = $@ ) {
177        my $charset = 'utf-8';
178        eval {
179            $app ||= MT->instance;
180            my $cfg = $app->config;
181            my $c   = $app->find_config;
182            $cfg->read_config($c);
183            $charset = $cfg->PublishCharset;
184        };
185        if ( $app && UNIVERSAL::isa( $app, 'MT::App' ) ) {
186            eval {
187                my %param = ( error => $err );
188                if ( $err =~ m/Bad ObjectDriver/ ) {
189                    $param{error_database_connection} = 1;
190                }
191                elsif ( $err =~ m/Bad CGIPath/ ) {
192                    $param{error_cgi_path} = 1;
193                }
194                elsif ( $err =~ m/Missing configuration file/ ) {
195                    $param{error_config_file} = 1;
196                }
197                my $page = $app->build_page( 'error.tmpl', \%param )
198                  or die $app->errstr;
199                print "Content-Type: text/html; charset=$charset\n\n";
200                print $page;
201            };
202            if ( my $err = $@ ) {
203                print "Content-Type: text/plain; charset=$charset\n\n";
204                print $app
205                  ? $app->translate( "Got an error: [_1]", $err )
206                  : "Got an error: $err";
207            }
208        }
209        else {
210            if ( $err =~ m/Missing configuration file/ ) {
211                my $host = $ENV{SERVER_NAME} || $ENV{HTTP_HOST};
212                $host =~ s/:\d+//;
213                my $port = $ENV{SERVER_PORT};
214                my $uri = $ENV{REQUEST_URI} || $ENV{PATH_INFO};
215                $uri =~ s/mt(\Q$SCRIPT_SUFFIX\E)?.*$//;
216                my $cgipath = '';
217                $cgipath = $port == 443 ? 'https' : 'http';
218                $cgipath .= '://' . $host;
219                $cgipath .= ( $port == 443 || $port == 80 ) ? '' : ':' . $port;
220                $cgipath .= $uri;
221
222                print "Status: 302 Moved\n";
223                print "Location: " . $cgipath . "mt-wizard.cgi\n\n";
224            }
225            else {
226                print "Content-Type: text/plain; charset=$charset\n\n";
227                print $app
228                  ? $app->translate( "Got an error: [_1]", $err )
229                  : "Got an error: $err\n";
230            }
231        }
232    }
233}
234
235sub app {
236    my $class = shift;
237    $mt_inst ||= $mt_inst{$class} ||= $class->construct(@_);
238}
239*instance = *app;
240
241sub set_instance {
242    my $class = shift;
243    $mt_inst = shift;
244}
245
246sub new {
247    my $mt = &instance_of;
248    $mt_inst ||= $mt;
249    $mt;
250}
251
252sub instance_of {
253    my $class = shift;
254    $mt_inst{$class} ||= $class->construct(@_);
255}
256
257sub construct {
258    my $class = shift;
259    my $mt = bless {}, $class;
260    local $mt_inst = $mt;
261    $mt->init(@_)
262      or die $mt->errstr;
263    $mt;
264}
265
266{
267    my %object_types;
268
269    sub model {
270        my $pkg = shift;
271        my ($k) = @_;
272        $object_types{$k} = $_[1] if scalar @_ > 1;
273        return $object_types{$k} if exists $object_types{$k};
274
275        if ($k =~ m/^(.+):meta$/) {
276            my $ppkg = $pkg->model($1);
277            my $mpkg = $ppkg->meta_pkg;
278            return $mpkg ? $object_types{$k} = $mpkg : undef;
279        }
280
281        my $model = $pkg->registry( 'object_types', $k );
282        if ( ref($model) eq 'ARRAY' ) {
283
284            # First element of an array *should* be a scalar; in case it isn't,
285            # return undef.
286            $model = $model->[0];
287            return undef if ref $model;
288        }
289        elsif ( ref($model) eq 'HASH' ) {
290
291            # If all we have is a hash, this doesn't tell us the package for
292            # this object type, so it's undefined.
293            return undef;
294        }
295        return undef unless $model;
296
297        # Element in object type hash is scalar, so return it
298        no strict 'refs';
299        unless ( defined *{ $model . '::__properties' } ) {
300            use strict 'refs';
301            eval "# line " . __LINE__ . " " . __FILE__ . "\nrequire $model;";
302            if ( $@ && ( $k =~ m/^(.+)\./ ) ) {
303
304                # x.foo can't be found, so try loading x
305                if ( my $ppkg = $pkg->model($1) ) {
306
307                    # well now see if $model is defined
308                    no strict 'refs';
309                    unless ( defined *{ $model . '::__properties' } ) {
310
311                        # if not, use parent package instead
312                        $model = $ppkg;
313                    }
314                }
315            }
316        }
317        return $object_types{$k} = $model;
318    }
319
320    sub models {
321        my $pkg = shift;
322        my ($k) = @_;
323
324        my @matches;
325        my $model = $pkg->registry('object_types');
326        foreach my $m ( keys %$model ) {
327            if ( $m =~ m/^\Q$k\E\.?/ ) {
328                push @matches, $m;
329            }
330        }
331        return @matches;
332    }
333}
334
335sub registry {
336    my $pkg = shift;
337
338    # if (!ref $pkg) {
339    #     return $pkg->instance->registry(@_);
340    # }
341    require MT::Component;
342    my $regs = MT::Component->registry(@_);
343    my $r;
344    if ($regs) {
345        foreach my $cr (@$regs) {
346
347            # in the event that our registry request returns something
348            # other than an array of hashes, return it as is instead of
349            # merging it together.
350            return $regs unless ref($cr) eq 'HASH';
351
352            # next unless ref($cr) eq 'HASH';
353            delete $cr->{plugin} if exists $cr->{plugin};
354            __merge_hash( $r ||= {}, $cr );
355        }
356    }
357    return $r;
358}
359
360# merges contents of two hashes, giving preference to the right side
361# if $replace is true; otherwise it will always append to the left side.
362sub __merge_hash {
363    my ( $h1, $h2, $replace ) = @_;
364    for my $k ( keys(%$h2) ) {
365        if ( exists( $h1->{$k} ) && ( !$replace ) ) {
366            if ( ref $h1->{$k} eq 'HASH' ) {
367                __merge_hash( $h1->{$k}, $h2->{$k}, ( $replace || 0 ) + 1 );
368            }
369            elsif ( ref $h1->{$k} eq 'ARRAY' ) {
370                if ( ref $h2->{$k} eq 'ARRAY' ) {
371                    push @{ $h1->{$k} }, @{ $h2->{$k} };
372                }
373                else {
374                    push @{ $h1->{$k} }, $h2->{$k};
375                }
376            }
377            else {
378                $h1->{$k} = [ $h1->{$k}, $h2->{$k} ];
379            }
380        }
381        else {
382            $h1->{$k} = $h2->{$k};
383        }
384    }
385}
386
387# The above functions can all be used to make MT objects (and subobjects).
388# The difference between them is characterized by these assertions:
389#
390#  $mt = MT::App::Search->new();
391#  assert($mt->isa('MT::App::Search'))
392#
393#  $mt1 = MT->instance
394#  $mt2 = MT->instance
395#  assert($mt1 == $mt2);
396#
397#  $mt1 = MT::App::CMS->construct()
398#  $mt2 = MT::App::CMS->construct()
399#  assert($mt1 != $mt2);
400#
401# TBD: make a test script for these.
402
403sub unplug {
404}
405
406sub config {
407    my $mt = shift;
408    ref $mt or $mt = MT->instance;
409    unless ( $mt->{cfg} ) {
410        require MT::ConfigMgr;
411        weaken( $mt->{cfg} = MT::ConfigMgr->instance );
412    }
413    if (@_) {
414        my $setting = shift;
415        @_ ? $mt->{cfg}->set( $setting, @_ ) : $mt->{cfg}->get($setting);
416    }
417    else {
418        $mt->{cfg};
419    }
420}
421
422sub request {
423    my $pkg  = shift;
424    my $inst = ref($pkg) ? $pkg : $pkg->instance;
425    unless ( $inst->{request} ) {
426        require MT::Request;
427        $inst->{request} = MT::Request->instance;
428    }
429    if (@_) {
430        $inst->{request}->stash(@_);
431    }
432    else {
433        $inst->{request};
434    }
435}
436
437sub log {
438    my $mt = shift;
439    unless ($plugins_installed) {
440        # finish init_schema here since we have to log something
441        # to the database.
442        $mt->init_schema();
443    }
444    my $msg;
445    if ( !@_ ) {    # single parameter to log, so $mt must be message
446        $msg = $mt;
447        $mt  = MT->instance;
448    }
449    else {          # multiple parameters to log; second one is message
450        $msg = shift;
451    }
452    my $log_class = $mt->model('log');
453    my $log = $log_class->new();
454    if ( ref $msg eq 'HASH' ) {
455        $log->set_values($msg);
456    }
457    elsif ( ( ref $msg ) && ( UNIVERSAL::isa( $msg, 'MT::Log' ) ) ) {
458        $log = $msg;
459    }
460    else {
461        $log->message($msg);
462    }
463    $log->level( MT::Log::INFO() )
464      unless defined $log->level;
465    $log->class('system')
466      unless defined $log->class;
467    $log->save();
468    print STDERR MT->translate( "Message: [_1]", $log->message ) . "\n"
469      if $MT::DebugMode;
470}
471my $plugin_full_path;
472
473sub run_tasks {
474    my $mt = shift;
475    require MT::TaskMgr;
476    MT::TaskMgr->run_tasks(@_);
477}
478
479sub add_plugin {
480    my $class = shift;
481    my ($plugin) = @_;
482    if ( ref $plugin eq 'HASH' ) {
483        require MT::Plugin;
484        $plugin = new MT::Plugin($plugin);
485    }
486    $plugin->{name} ||= $plugin_sig;
487    $plugin->{plugin_sig} = $plugin_sig;
488
489    my $id = $plugin->id;
490    unless ($plugin_envelope) {
491        warn "MT->add_plugin improperly called outside of MT plugin load loop.";
492        return;
493    }
494    $plugin->envelope($plugin_envelope);
495    Carp::confess("You cannot register multiple plugin objects from a single script. $plugin_sig")
496      if exists( $Plugins{$plugin_sig} )
497      && ( exists $Plugins{$plugin_sig}{object} );
498
499    $Components{ lc $id } = $plugin if $id;
500    $Plugins{$plugin_sig}{object} = $plugin;
501    $plugin->{full_path}  = $plugin_full_path;
502    $plugin->path($plugin_full_path);
503    unless ( $plugin->{registry} && ( %{ $plugin->{registry} } ) ) {
504        $plugin->{registry} = $plugin_registry;
505    }
506    if ( $plugin->{registry} ) {
507        if ( my $settings = $plugin->{registry}{config_settings} ) {
508            $settings = $plugin->{registry}{config_settings} = $settings->()
509              if ref($settings) eq 'CODE';
510            $class->config->define($settings);
511        }
512    }
513    push @Components, $plugin;
514    1;
515}
516
517our %CallbackAlias;
518our $CallbacksEnabled = 1;
519my %CallbacksEnabled;
520my @Callbacks;
521
522sub add_callback {
523    my $class = shift;
524    my ( $meth, $priority, $plugin, $code ) = @_;
525    if ( $meth =~ m/^(.+::)?([^\.]+)(\..+)?$/ ) {
526
527        # Remap (whatever)::(name).(something)
528        if ( exists $CallbackAlias{$2} ) {
529            $meth = $CallbackAlias{$2};
530            $meth = $1 . $meth if $1;
531            $meth = $meth . $3 if $3;
532        }
533    }
534    $meth = $CallbackAlias{$meth} if exists $CallbackAlias{$meth};
535    my $internal = 0;
536    if ( ref $plugin ) {
537        if ( ( defined $mt_inst ) && ( $plugin == $mt_inst ) ) {
538            $plugin   = undef;
539            $internal = 1;
540        }
541        elsif ( !UNIVERSAL::isa( $plugin, "MT::Component" ) ) {
542            return $class->trans_error(
543"If present, 3rd argument to add_callback must be an object of type MT::Component or MT::Plugin"
544            );
545        }
546    }
547    if ( ( ref $code ) ne 'CODE' ) {
548        if ( ref $code ) {
549            return $class->trans_error(
550                '4th argument to add_callback must be a CODE reference.');
551        }
552        else {
553            # Defer until callback is used
554            # if ($plugin) {
555            #     $code = MT->handler_to_coderef($code);
556            # }
557        }
558    }
559
560    # 0 and 11 are exclusive.
561    if ( $priority == 0 || $priority == 11 ) {
562        if ( $Callbacks[$priority]->{$meth} ) {
563            return $class->trans_error("Two plugins are in conflict");
564        }
565    }
566    return $class->trans_error( "Invalid priority level [_1] at add_callback",
567        $priority )
568      if ( ( $priority < 0 ) || ( $priority > 11 ) );
569    require MT::Callback;
570    $CallbacksEnabled{$meth} = 1;
571    ## push @{$Plugins{$plugin_sig}{callbacks}}, "$meth Callback" if $plugin_sig;
572    my $cb = new MT::Callback(
573        plugin   => $plugin,
574        code     => $code,
575        priority => $priority,
576        internal => $internal,
577        method   => $meth
578    );
579    push @{ $Callbacks[$priority]->{$meth} }, $cb;
580    $cb;
581}
582
583sub remove_callback {
584    my $class    = shift;
585    my ($cb)     = @_;
586    my $priority = $cb->{priority};
587    my $method   = $cb->{method};
588    my $list     = $Callbacks[$priority];
589    return unless $list;
590    my $cbarr = $list->{$method};
591    return unless $cbarr;
592    @$cbarr = grep { $_ != $cb } @$cbarr;
593}
594
595# For use by MT internal code
596sub _register_core_callbacks {
597    my $class = shift;
598    my ($callback_table) = @_;
599    foreach my $name ( keys %$callback_table ) {
600        $class->add_callback( $name, 5, $mt_inst, $callback_table->{$name} )
601          || return;
602    }
603    1;
604}
605
606sub register_callbacks {
607    my $class = shift;
608    my ($callback_list) = @_;
609    foreach my $cb (@$callback_list) {
610        $class->add_callback( $cb->{name}, $cb->{priority}, $cb->{plugin},
611            $cb->{code} )
612          || return;
613    }
614    1;
615}
616
617our $CB_ERR;
618sub callback_error { $CB_ERR = $_[0]; }
619sub callback_errstr { $CB_ERR }
620
621sub run_callback {
622    my $class = shift;
623    my ( $cb, @args ) = @_;
624
625    $cb->error();    # reset the error string
626    my $result = eval {
627        # line __LINE__ __FILE__
628        $cb->invoke(@args);
629    };
630    if ( my $err = $@ ) {
631        $cb->error($err);
632        my $plugin = $cb->{plugin};
633        my $name;
634        if ( $cb->{internal} ) {
635            $name = "Internal callback";
636        }
637        elsif ( UNIVERSAL::isa( $plugin, 'MT::Plugin' ) ) {
638            $name = $plugin->name() || MT->translate("Unnamed plugin");
639        }
640        else {
641            $name = MT->translate("Unnamed plugin");
642        }
643        require MT::Log;
644        MT->log(
645            {
646                message => MT->translate( "[_1] died with: [_2]", $name, $err ),
647                class   => 'system',
648                category => 'callback',
649                level    => MT::Log::ERROR(),
650            }
651        );
652        return 0;
653    }
654    if ( $cb->errstr() ) {
655        return 0;
656    }
657    return $result;
658}
659
660# A callback should return a true/false value. The result of
661# run_callbacks is the logical AND of all the callback's return
662# values. Some hookpoints will ignore the return value: e.g. object
663# callbacks don't use it. By convention, those that use it have Filter
664# at the end of their names (CommentPostFilter, CommentThrottleFilter,
665# etc.)
666# Note: this composition is not short-circuiting. All callbacks are
667# executed even if one has already returned false.
668# ALSO NOTE: failure (dying or setting $cb->errstr) does not force a
669# "false" return.
670# THINK: are there cases where a true value should override all false values?
671# that is, where logical OR is the right way to compose multiple callbacks?
672sub run_callbacks {
673    my $class = shift;
674    my ( $meth, @args ) = @_;
675    return 1 unless $CallbacksEnabled && %CallbacksEnabled;
676    $meth = $CallbackAlias{$meth} if exists $CallbackAlias{$meth};
677    my @methods;
678
679    # execution:
680    #   Full::Name.<variant>
681    #   *::Name.<variant> OR Name.<variant>
682    #   Full::Name
683    #   *::Name OR Name
684    push @methods, $meth if $CallbacksEnabled{$meth};    # bleh::blah variant
685    if ( $meth =~ /::/ ) {    # presence of :: implies it's an obj. cb
686        my $name = $meth;
687        $name =~ s/^.*::([^:]*)$/$1/;
688        $name = $CallbackAlias{ '*::' . $name }
689          if exists $CallbackAlias{ '*::' . $name };
690        push @methods, '*::' . $name
691          if $CallbacksEnabled{ '*::' . $name };    # *::blah variant
692        push @methods, $name if $CallbacksEnabled{$name};    # blah variant
693    }
694    if ( $meth =~ /\./ ) {    # presence of ' ' implies it is a variant callback
695        my ($name) = split /\./, $meth, 2;
696        $name = $CallbackAlias{$name} if exists $CallbackAlias{$name};
697        push @methods, $name if $CallbacksEnabled{$name};    # bleh::blah
698        if ( $name =~ m/::/ ) {
699            my $name2 = $name;
700            $name2 =~ s/^.*::([^:]*)$/$1/;
701            $name2 = $CallbackAlias{ '*::' . $name2 }
702              if exists $CallbackAlias{ '*::' . $name2 };
703            push @methods, '*::' . $name2
704              if $CallbacksEnabled{ '*::' . $name2 };        # *::blah
705            push @methods, $name2 if $CallbacksEnabled{$name2};    # blah
706        }
707    }
708    return 1 unless @methods;
709
710    $CallbacksEnabled{$_} = 0 for @methods;
711    my @errors;
712    my $filter_value = 1;
713    my $first_error;
714
715    foreach my $callback_sheaf (@Callbacks) {
716        for my $meth (@methods) {
717            if ( my $set = $callback_sheaf->{$meth} ) {
718                for my $cb (@$set) {
719                    my $result = $class->run_callback( $cb, @args );
720                    $filter_value &&= $result;
721                    if ( !$result ) {
722                        if ( $cb->errstr() ) {
723                            push @errors, $cb->errstr();
724                        }
725                        if ( !defined($first_error) ) {
726                            $first_error = $cb->errstr();
727                        }
728                    }
729                }
730            }
731        }
732    }
733
734    callback_error( join( '', @errors ) );
735
736    $CallbacksEnabled{$_} = 1 for @methods;
737    if ( !$filter_value ) {
738        return $class->error($first_error);
739    }
740    else {
741        return $filter_value;
742    }
743}
744
745sub user_class {
746    shift->{user_class};
747}
748
749sub find_config {
750    my $mt = shift;
751    my ($param) = @_;
752
753    $param->{Config}    ||= $ENV{MT_CONFIG};
754    $param->{Directory} ||= $ENV{MT_HOME};
755    if ( !$param->{Directory} ) {
756        if ( $param->{Config} ) {
757            $param->{Directory} = dirname( $param->{Config} );
758        }
759        else {
760            $param->{Directory} = dirname($0) || $ENV{PWD} || '.';
761        }
762    }
763
764    # the directory is the more important parameter between it and
765    # the config parameter. if config is unreadable, then scan for
766    # a config file using the directory as a base.  we support
767    # either mt.cfg or mt-config.cgi for the config file name. the
768    # latter being a more secure choice since it is unreadable from
769    # a browser.
770    for my $cfg_file ( $param->{Config},
771        File::Spec->catfile( $param->{Directory}, 'mt-config.cgi' ),
772        'mt-config.cgi' )
773    {
774        return $cfg_file if $cfg_file && -r $cfg_file && -f $cfg_file;
775    }
776    return undef;
777}
778
779sub init_schema {
780    require MT::Object;
781    MT::Object->install_pre_init_properties();
782}
783
784sub init_permissions {
785    require MT::Permission;
786    MT::Permission->init_permissions;
787}
788
789sub init_config {
790    my $mt = shift;
791    my ($param) = @_;
792
793    my $cfg_file = $mt->find_config($param);
794    return $mt->error(
795"Missing configuration file. Maybe you forgot to move mt-config.cgi-original to mt-config.cgi?"
796    ) unless $cfg_file;
797    $cfg_file = File::Spec->rel2abs($cfg_file);
798
799    # translate the config file's location to an absolute path, so we
800    # can use that directory as a basis for calculating other relative
801    # paths found in the config file.
802    my $config_dir = $mt->{config_dir} = dirname($cfg_file);
803
804    # store the mt_dir (home) as an absolute path; fallback to the config
805    # directory if it isn't set.
806    $mt->{mt_dir} =
807      $param->{Directory}
808      ? File::Spec->rel2abs( $param->{Directory} )
809      : $mt->{config_dir};
810    $mt->{mt_dir} ||= dirname($0);
811
812    # also make note of the active application path; this is derived by
813    # checking the PWD environment variable, the dirname of $0,
814    # the directory of SCRIPT_FILENAME and lastly, falls back to mt_dir
815    $mt->{app_dir} = $ENV{PWD} || "";
816    $mt->{app_dir} = dirname($0)
817      if !$mt->{app_dir}
818      || !File::Spec->file_name_is_absolute( $mt->{app_dir} );
819    $mt->{app_dir} = dirname( $ENV{SCRIPT_FILENAME} )
820      if $ENV{SCRIPT_FILENAME}
821      && ( !$mt->{app_dir}
822        || ( !File::Spec->file_name_is_absolute( $mt->{app_dir} ) ) );
823    $mt->{app_dir} ||= $mt->{mt_dir};
824    $mt->{app_dir} = File::Spec->rel2abs( $mt->{app_dir} );
825
826    my $cfg = $mt->config;
827    $cfg->define( $mt->registry('config_settings') );
828    $cfg->read_config($cfg_file) or return $mt->error( $cfg->errstr );
829    $mt->{cfg_file} = $cfg_file;
830
831    my @mt_paths = $cfg->paths;
832    for my $meth (@mt_paths) {
833        my $path = $cfg->get( $meth, undef );
834        my $type = $cfg->type($meth);
835        if ( defined $path ) {
836            if ( $type eq 'ARRAY' ) {
837                my @paths = $cfg->get($meth);
838                local $_;
839                foreach (@paths) {
840                    next if File::Spec->file_name_is_absolute($_);
841                    $_ = File::Spec->catfile( $config_dir, $_ );
842                }
843                $cfg->$meth( \@paths );
844            }
845            else {
846                if ( !File::Spec->file_name_is_absolute($path) ) {
847                    $path = File::Spec->catfile( $config_dir, $path );
848                    $cfg->$meth($path);
849                }
850            }
851        }
852        else {
853            next if $type eq 'ARRAY';
854            my $path = $cfg->default($meth);
855            if ( defined $path ) {
856                $cfg->$meth( File::Spec->catfile( $config_dir, $path ) );
857            }
858        }
859    }
860
861    return $mt->trans_error("Bad ObjectDriver config")
862      unless $cfg->ObjectDriver;
863
864    if ( $MT::DebugMode = $cfg->DebugMode ) {
865        require Data::Dumper;
866        $Data::Dumper::Terse    = 1;
867        $Data::Dumper::Maxdepth = 4;
868        $Data::Dumper::Sortkeys = 1;
869        $Data::Dumper::Indent   = 1;
870    }
871
872    if ($cfg->PerformanceLogging && $cfg->ProcessMemoryCommand) {
873        $mt->log_times();
874    }
875
876    $mt->set_language( $cfg->DefaultLanguage );
877
878    my $cgi_path = $cfg->CGIPath;
879    if ( !$cgi_path || $cgi_path =~ m!http://www\.example\.com/! ) {
880        return $mt->trans_error("Bad CGIPath config");
881    }
882
883    $mt->{cfg} = $cfg;
884
885    1;
886}
887
888{
889my ($memory_start);
890sub log_times {
891    my $pkg = shift;
892
893    my $timer = $pkg->get_timer;
894    return unless $timer;
895
896    my $memory;
897    my $cmd = $pkg->config->ProcessMemoryCommand;
898    if ($cmd) {
899        my $re;
900        if (ref($cmd) eq 'HASH') {
901            $re = $cmd->{regex};
902            $cmd = $cmd->{command};
903        }
904        $cmd =~ s/\$\$/$$/g;
905        $memory = `$cmd`;
906        if ($re) {
907            if ($memory =~ m/$re/) {
908                $memory = $1;
909                $memory =~ s/\D//g;
910            }
911        } else {
912            $memory =~ s/\s+//gs;
913        }
914    }
915
916    # Called at the start of the process; so we're only recording
917    # the memory usage at the start of the app right now.
918    unless ($timer->{elapsed}) {
919        $memory_start = $memory;
920        return;
921    }
922
923    require File::Spec;
924    my $dir = MT->config('PerformanceLoggingPath') or return;
925
926    my @time = localtime(time);
927    my $file = sprintf("pl-%04d%02d%02d.log", $time[5] + 1900, $time[4]+1, $time[3]);
928    my $log_file = File::Spec->catfile( $dir, $file );
929
930    my $first_write = ! -f $log_file;
931
932    local *PERFLOG;
933    open PERFLOG, ">>$log_file";
934    require Fcntl;
935    flock(PERFLOG, Fcntl::LOCK_EX());
936
937    if ($first_write) {
938        require Config;
939        my ($osname, $osvers) = ($Config::Config{osname}, $Config::Config{osvers});
940        print PERFLOG "# Operating System: $osname/$osvers\n";
941        print PERFLOG "# Platform: $^O\n";
942        my $ver = ref($^V) eq 'version' ? $^V->normal : ( $^V ? join('.', unpack 'C*', $^V) : $] );
943        print PERFLOG "# Perl Version: $ver\n";
944        print PERFLOG "# Web Server: $ENV{SERVER_SOFTWARE}\n";
945        require MT::Object;
946        my $driver = MT::Object->driver;
947        if ($driver) {
948            my $dbh = $driver->r_handle;
949            if ($dbh) {
950                my $dbname = $dbh->get_info( 17 ); # SQL_DBMS_NAME
951                my $dbver = $dbh->get_info( 18 ); # SQL_DBMS_VER
952                if ($dbname && $dbver) {
953                    print PERFLOG "# Database: $dbname/$dbver\n";
954                }
955            }
956        }
957        my ($drname, $drh) = each %DBI::installed_drh;
958        print PERFLOG "# Database Library: DBI/" . $DBI::VERSION . "; DBD/" . $drh->{Version} . "\n";
959        if ($ENV{MOD_PERL}) {
960            print PERFLOG "# App Mode: mod_perl\n";
961        }
962        elsif ($ENV{FAST_CGI}) {
963            print PERFLOG "# App Mode: FastCGI\n";
964        }
965        else {
966            print PERFLOG "# App Mode: CGI\n";
967        }
968    }
969
970    if ($memory) {
971        print PERFLOG $timer->dump_line("mem_start=$memory_start", "mem_end=$memory");
972    } else {
973        print PERFLOG $timer->dump_line();
974    }
975
976    close PERFLOG;
977}
978}
979
980sub get_timer {
981    my $mt = shift;
982    $mt = MT->instance unless ref $mt;
983    my $timer = $mt->request('timer');
984    unless (defined $timer) {
985        if (MT->config('PerformanceLogging')) {
986            my $uri;
987            if ($mt->isa('MT::App')) {
988                $uri = $mt->uri( args => { $mt->param_hash } );
989            }
990            require MT::Util::ReqTimer;
991            $timer = MT::Util::ReqTimer->new( $uri );
992        } else {
993            $timer = 0;
994        }
995        $mt->request('timer', $timer);
996    }
997    return $timer;
998}
999
1000sub time_this {
1001    my $mt = shift;
1002    my ($str, $code) = @_;
1003    my $timer = $mt->get_timer();
1004    my $ret;
1005    if ($timer) {
1006        $timer->pause_partial();
1007        $ret = $code->();
1008        $timer->mark($str);
1009    } else {
1010        $ret = $code->();
1011    }
1012    return $ret;
1013}
1014
1015sub init_config_from_db {
1016    my $mt = shift;
1017    my ($param) = @_;
1018    my $cfg = $mt->config;
1019    $cfg->read_config_db();
1020
1021    # Tell any instantiated drivers to reconfigure themselves as necessary
1022    MT::ObjectDriverFactory->configure;
1023
1024    1;
1025}
1026
1027sub bootstrap {
1028    my $pkg = shift;
1029    $pkg->init_paths() or return;
1030    $pkg->init_core()  or return;
1031}
1032
1033sub init_paths {
1034    my $mt = shift;
1035    my ($param) = @_;
1036
1037    # determine MT directory
1038    my ($orig_dir);
1039    require File::Spec;
1040    if ( !( $MT_DIR = $ENV{MT_HOME} ) ) {
1041        if ( $0 =~ m!(.*([/\\]))! ) {
1042            $orig_dir = $MT_DIR = $1;
1043            my $slash = $2;
1044            $MT_DIR =~ s!(?:[/\\]|^)(?:plugins[/\\].*|tools[/\\])$!$slash!;
1045            $MT_DIR = '' if ( $MT_DIR =~ m!^\.?[\\/]$! );
1046        }
1047        else {
1048
1049            # MT_DIR/lib/MT.pm -> MT_DIR/lib -> MT_DIR
1050            $MT_DIR = dirname( dirname( File::Spec->rel2abs(__FILE__) ) );
1051        }
1052        unless ($MT_DIR) {
1053            $orig_dir = $MT_DIR = $ENV{PWD} || '.';
1054            $MT_DIR =~ s!(?:[/\\]|^)(?:plugins[/\\].*|tools[/\\]?)$!!;
1055        }
1056        $ENV{MT_HOME} = $MT_DIR;
1057    }
1058    unshift @INC, File::Spec->catdir( $MT_DIR,   'extlib' );
1059    unshift @INC, File::Spec->catdir( $orig_dir, 'lib' )
1060      if $orig_dir && ( $orig_dir ne $MT_DIR );
1061
1062    $mt->set_language('en_US');
1063
1064    if ( my $cfg_file = $mt->find_config($param) ) {
1065        $cfg_file = File::Spec->rel2abs($cfg_file);
1066        $CFG_FILE = $cfg_file;
1067    }
1068    else {
1069        return $mt->trans_error(
1070"Missing configuration file. Maybe you forgot to move mt-config.cgi-original to mt-config.cgi?"
1071        ) if ref($mt);
1072    }
1073
1074    # store the mt_dir (home) as an absolute path; fallback to the config
1075    # directory if it isn't set.
1076    $MT_DIR ||=
1077      $param->{directory}
1078      ? File::Spec->rel2abs( $param->{directory} )
1079      : $CFG_DIR;
1080    $MT_DIR ||= dirname($0);
1081
1082    # also make note of the active application path; this is derived by
1083    # checking the PWD environment variable, the dirname of $0,
1084    # the directory of SCRIPT_FILENAME and lastly, falls back to mt_dir
1085    $APP_DIR = $ENV{PWD} || "";
1086    $APP_DIR = dirname($0)
1087      if !$APP_DIR || !File::Spec->file_name_is_absolute($APP_DIR);
1088    $APP_DIR = dirname( $ENV{SCRIPT_FILENAME} )
1089      if $ENV{SCRIPT_FILENAME}
1090      && ( !$APP_DIR || ( !File::Spec->file_name_is_absolute($APP_DIR) ) );
1091    $APP_DIR ||= $MT_DIR;
1092    $APP_DIR = File::Spec->rel2abs($APP_DIR);
1093
1094    return 1;
1095}
1096
1097sub init_core {
1098    my $mt = shift;
1099    return if exists $Components{'core'};
1100    require MT::Core;
1101    my $c = MT::Core->new( { id => 'core', path => $MT_DIR } )
1102      or die MT::Core->errstr;
1103    $Components{'core'} = $c;
1104
1105    push @Components, $c;
1106    return 1;
1107}
1108
1109sub init_lang_defaults {
1110    my $mt = shift;
1111    my $cfg = $mt->config;
1112   
1113    $cfg->DefaultLanguage('en_US') unless $cfg->DefaultLanguage;
1114   
1115    my %lang_settings = (
1116        'NewsboxURL'         => 'NEWSBOX_URL',
1117        'LearningNewsURL'    => 'LEARNINGNEWS_URL',
1118        'SupportURL'         => 'SUPPORT_URL',
1119        'NewsURL'            => 'NEWS_URL',
1120        'DefaultTimezone'    => 'DEFAULT_TIMEZONE',
1121        'TimeOffset'         => 'DEFAULT_TIMEZONE',
1122        'MailEncoding'       => 'MAIL_ENCODING',
1123        'ExportEncoding'     => 'EXPORT_ENCODING',
1124        'LogExportEncoding'  => 'LOG_EXPORT_ENCODING',
1125        'CategoryNameNodash' => 'CATEGORY_NAME_NODASH',
1126        'PublishCharset'     => 'PUBLISH_CHARSET'
1127    );
1128
1129    require MT::I18N;
1130    foreach my $setting (keys %lang_settings) {
1131        my $const = $lang_settings{$setting};
1132        $cfg->$setting(MT::I18N::const($const));
1133    }
1134   
1135    return 1;
1136}
1137
1138sub init {
1139    my $mt    = shift;
1140    my %param = @_;
1141
1142    $mt->bootstrap() unless $MT_DIR;
1143    $mt->{mt_dir}     = $MT_DIR;
1144    $mt->{config_dir} = $CFG_DIR;
1145    $mt->{app_dir}    = $APP_DIR;
1146
1147    $mt->init_callbacks();
1148
1149    ## Initialize the language to the default in case any errors occur in
1150    ## the rest of the initialization process.
1151    $mt->init_config( \%param ) or return;
1152    $mt->init_lang_defaults(@_) or return;
1153    $mt->init_addons(@_)       or return;
1154    $mt->init_config_from_db( \%param ) or return;
1155    $mt->init_plugins(@_)       or return;
1156    $plugins_installed = 1;
1157    $mt->init_schema();
1158    $mt->init_permissions();
1159
1160    # Load MT::Log so constants are available
1161    require MT::Log;
1162
1163    $mt->run_callbacks('post_init', $mt, \%param);
1164    return $mt;
1165}
1166
1167sub init_callbacks {
1168    my $mt = shift;
1169    MT->_register_core_callbacks({
1170        'build_file_filter' => sub { MT->publisher->queue_build_file_filter(@_) },
1171        'cms_upload_file' => \&core_upload_file_to_sync,
1172        'api_upload_file' => \&core_upload_file_to_sync,
1173    });
1174}
1175
1176sub core_upload_file_to_sync {
1177    my ($cb, %args) = @_;
1178    MT->upload_file_to_sync(%args);
1179}
1180
1181sub upload_file_to_sync {
1182    my $class = shift;
1183    my (%args) = @_;
1184
1185    # no need to do this unless we're syncing stuff.
1186    return unless MT->config('SyncTarget');
1187
1188    my $url = $args{url};
1189    my $file = $args{file};
1190    return unless -f $file;
1191
1192    my $blog = $args{blog};
1193    my $blog_id = $blog->id;
1194    return unless $blog->publish_queue;
1195
1196    require MT::FileInfo;
1197    my $base_url = $url;
1198    $base_url =~ s!^https?://[^/]+!!;
1199    my $fi = MT::FileInfo->load({ blog_id => $blog_id, url => $base_url });
1200    if (!$fi) {
1201        $fi = new MT::FileInfo;
1202        $fi->blog_id($blog_id);
1203        $fi->url($base_url);
1204        $fi->file_path($file);
1205    } else {
1206        $fi->file_path($file);
1207    }
1208    $fi->save;
1209
1210    require MT::TheSchwartz;
1211    require TheSchwartz::Job;
1212    my $job = TheSchwartz::Job->new();
1213    $job->funcname('MT::Worker::Sync');
1214    $job->uniqkey( $fi->id );
1215    $job->coalesce( ( $fi->blog_id || 0 ) . ':' . $$ . ':' . ( time - ( time % 10 ) ) );
1216    MT::TheSchwartz->insert($job);
1217}
1218
1219sub init_addons {
1220    my $mt = shift;
1221    my $cfg = $mt->config;
1222    my @PluginPaths;
1223
1224    unshift @PluginPaths, File::Spec->catdir( $MT_DIR, 'addons' );
1225    return $mt->_init_plugins_core({}, 1, \@PluginPaths);
1226}
1227
1228sub init_plugins {
1229    my $mt = shift;
1230
1231    # Load compatibility module for prior version
1232    # This should always be MT::Compat::v(MAJOR_RELEASE_VERSION - 1).
1233    require MT::Compat::v3;
1234
1235    require MT::Plugin;
1236    my $cfg          = $mt->config;
1237    my $use_plugins  = $cfg->UsePlugins;
1238    my @PluginPaths  = $cfg->PluginPath;
1239    my $PluginSwitch = $cfg->PluginSwitch || {};
1240    return $mt->_init_plugins_core($PluginSwitch, $use_plugins, \@PluginPaths);
1241}
1242
1243sub _init_plugins_core {
1244    my $mt = shift;
1245    my ($PluginSwitch, $use_plugins, $PluginPaths) = @_;
1246
1247    my $timer;
1248    if ($mt->config->PerformanceLogging) {
1249        $timer = $mt->get_timer();
1250    }
1251
1252    foreach my $PluginPath (@$PluginPaths) {
1253        my $plugin_lastdir = $PluginPath;
1254        $plugin_lastdir =~ s![\\/]$!!;
1255        $plugin_lastdir =~ s!.*[\\/]!!;
1256        local *DH;
1257        if ( opendir DH, $PluginPath ) {
1258            my @p = readdir DH;
1259          PLUGIN:
1260            for my $plugin (@p) {
1261                next if ( $plugin =~ /^\.\.?$/ || $plugin =~ /~$/ );
1262
1263                my $load_plugin = sub {
1264                    my ( $plugin, $sig ) = @_;
1265                    die "Bad plugin filename '$plugin'"
1266                      if ( $plugin !~ /^([-\\\/\@\:\w\.\s~]+)$/ );
1267                    local $plugin_sig      = $sig;
1268                    local $plugin_registry = {};
1269                    $plugin = $1;
1270                    if (
1271                        !$use_plugins
1272                        || ( exists $PluginSwitch->{$plugin_sig}
1273                            && !$PluginSwitch->{$plugin_sig} )
1274                      )
1275                    {
1276                        $Plugins{$plugin_sig}{full_path} = $plugin_full_path;
1277                        $Plugins{$plugin_sig}{enabled}   = 0;
1278                        return 0;
1279                    }
1280                    return 0 if exists $Plugins{$plugin_sig};
1281                    $Plugins{$plugin_sig}{full_path} = $plugin_full_path;
1282                    $timer->pause_partial if $timer;
1283                    eval "# line " . __LINE__ . " " . __FILE__ . "\nrequire '$plugin';";
1284                    $timer->mark("Loaded plugin " . $sig) if $timer;
1285                    if ($@) {
1286                        $Plugins{$plugin_sig}{error} = $@;
1287                        # Issue MT log within another eval block in the
1288                        # event that the plugin error is happening before
1289                        # the database has been initialized...
1290                        eval {
1291                            # line __LINE__ __FILE__
1292                            require MT::Log;
1293                            $mt->log(
1294                                {
1295                                    message => $mt->translate(
1296                                        "Plugin error: [_1] [_2]", $plugin,
1297                                        $Plugins{$plugin_sig}{error}
1298                                    ),
1299                                    class => 'system',
1300                                    level => MT::Log::ERROR()
1301                                }
1302                            );
1303                        };
1304                        return 0;
1305                    }
1306                    else {
1307                        if ( my $obj = $Plugins{$plugin_sig}{object} ) {
1308                            $obj->init_callbacks();
1309                        }
1310                        else {
1311
1312                            # A plugin did not register itself, so
1313                            # create a dummy plugin object which will
1314                            # cause it to show up in the plugin listing
1315                            # by it's filename.
1316                            MT->add_plugin( {} );
1317                        }
1318                    }
1319                    $Plugins{$plugin_sig}{enabled} = 1;
1320                    return 1;
1321                };
1322                $plugin_full_path = File::Spec->catfile( $PluginPath, $plugin );
1323                if ( -f $plugin_full_path ) {
1324                    $plugin_envelope = $plugin_lastdir;
1325                    $load_plugin->( $plugin_full_path, $plugin )
1326                      if $plugin_full_path =~ /\.pl$/;
1327                }
1328                else {
1329                    my $plugin_dir = $plugin;
1330                    $plugin_envelope = "$plugin_lastdir/" . $plugin;
1331
1332                    # handle config.yaml
1333                    my $yaml =
1334                      File::Spec->catdir( $plugin_full_path, 'config.yaml' );
1335
1336                    foreach my $lib (qw(lib extlib)) {
1337                        my $plib = File::Spec->catdir( $plugin_full_path, $lib );
1338                        unshift @INC, $plib if -d $plib;
1339                    }
1340
1341                    if ( -f $yaml ) {
1342                        my $pclass =
1343                          $plugin_dir =~ m/\.pack$/
1344                          ? 'MT::Component'
1345                          : 'MT::Plugin';
1346
1347                        # Don't process disabled plugin config.yaml files.
1348                        if (
1349                            $pclass eq 'MT::Plugin'
1350                            && (
1351                                !$use_plugins
1352                                || ( exists $PluginSwitch->{$plugin_dir}
1353                                    && !$PluginSwitch->{$plugin_dir} )
1354                            )
1355                          )
1356                        {
1357                            $Plugins{$plugin_dir}{full_path} =
1358                              $plugin_full_path;
1359                            $Plugins{$plugin_dir}{enabled} = 0;
1360                            next;
1361                        }
1362                        my $id = lc $plugin_dir;
1363                        $id =~ s/\.\w+$//;
1364                        my $p = $pclass->new(
1365                            {
1366                                id       => $id,
1367                                path     => $plugin_full_path,
1368                                envelope => $plugin_envelope
1369                            }
1370                        );
1371
1372                        # rebless? based on config?
1373                        local $plugin_sig = $plugin_dir;
1374                        MT->add_plugin($p);
1375                        $p->init_callbacks()
1376                            if $pclass eq 'MT::Plugin';
1377                        next;
1378                    }
1379
1380                    opendir SUBDIR, $plugin_full_path;
1381                    my @plugins = readdir SUBDIR;
1382                    closedir SUBDIR;
1383                    for my $plugin (@plugins) {
1384                        next if $plugin !~ /\.pl$/;
1385                        my $plugin_file =
1386                          File::Spec->catfile( $plugin_full_path, $plugin );
1387                        if ( -f $plugin_file ) {
1388                            $load_plugin->(
1389                                $plugin_file, $plugin_dir . '/' . $plugin
1390                            );
1391                        }
1392                    }
1393                }
1394            }
1395            closedir DH;
1396        }
1397    }
1398
1399    # Reset the Text_filters hash in case it was preloaded by plugins by
1400    # calling all_text_filters (Markdown in particular does this).
1401    # Upon calling all_text_filters again, it will be properly loaded by
1402    # querying the registry.
1403    %Text_filters = ();
1404
1405    1;
1406}
1407
1408my %addons;
1409
1410sub find_addons {
1411    my $mt = shift;
1412    my ($type) = @_;
1413
1414    unless (%addons) {
1415        my $addon_path = File::Spec->catdir( $MT_DIR, 'addons' );
1416        local *DH;
1417        if ( opendir DH, $addon_path ) {
1418            my @p = readdir DH;
1419            foreach my $p (@p) {
1420                next if $p eq '.' || $p eq '..';
1421                my $full_path = File::Spec->catdir( $addon_path, $p );
1422                if ( -d $full_path ) {
1423                    if ( $p =~ m/^(.+)\.(\w+)$/ ) {
1424                        my $label = $1;
1425                        my $id    = lc $1;
1426                        my $type  = $2;
1427                        if ( $type eq 'pack' ) {
1428                            $label .= ' Pack';
1429                        }
1430                        elsif ( $type eq 'theme' ) {
1431                            $label .= ' Theme';
1432                        }
1433                        elsif ( $type eq 'plugin' ) {
1434                            $label .= ' Plugin';
1435                        }
1436                        push @{ $addons{$type} },
1437                          {
1438                            label    => $label,
1439                            id       => $id,
1440                            envelope => 'addons/' . $p . '/',
1441                            path     => $full_path,
1442                          };
1443                    }
1444                }
1445            }
1446        }
1447    }
1448    if ($type) {
1449        my $addons = $addons{$type} ||= [];
1450        return $addons;
1451    }
1452    return 1;
1453}
1454
1455*mt_dir = \&server_path;
1456sub server_path { $_[0]->{mt_dir} }
1457sub app_dir     { $_[0]->{app_dir} }
1458sub config_dir  { $_[0]->{config_dir} }
1459
1460sub component {
1461    my $mt = shift;
1462    my ($id) = @_;
1463    return $Components{ lc $id };
1464}
1465
1466sub publisher {
1467    my $mt = shift;
1468    $mt = $mt->instance unless ref $mt;
1469    unless ( $mt->{WeblogPublisher} ) {
1470        require MT::WeblogPublisher;
1471        $mt->{WeblogPublisher} = new MT::WeblogPublisher();
1472    }
1473    $mt->{WeblogPublisher};
1474}
1475
1476sub rebuild {
1477    my $mt = shift;
1478    $mt->publisher->rebuild(@_)
1479      or return $mt->error( $mt->publisher->errstr );
1480}
1481
1482sub rebuild_entry {
1483    my $mt = shift;
1484    $mt->publisher->rebuild_entry(@_)
1485      or return $mt->error( $mt->publisher->errstr );
1486}
1487
1488sub rebuild_indexes {
1489    my $mt = shift;
1490    $mt->publisher->rebuild_indexes(@_)
1491      or return $mt->error( $mt->publisher->errstr );
1492}
1493
1494sub rebuild_archives {
1495    my $mt = shift;
1496    $mt->publisher->rebuild_archives(@_)
1497      or return $mt->error( $mt->publisher->errstr );
1498}
1499
1500sub ping {
1501    my $mt    = shift;
1502    my %param = @_;
1503    my $blog;
1504    require MT::Entry;
1505    require MT::Util;
1506    unless ( $blog = $param{Blog} ) {
1507        my $blog_id = $param{BlogID};
1508        $blog = MT::Blog->load($blog_id)
1509          or return $mt->trans_error( "Load of blog '[_1]' failed: [_2]",
1510            $blog_id, MT::Blog->errstr );
1511    }
1512
1513    my (@res);
1514
1515    my $send_updates = 1;
1516    if ( exists $param{OldStatus} ) {
1517        ## If this is a new entry (!$old_status) OR the status was previously
1518        ## set to draft, and is now set to publish, send the update pings.
1519        my $old_status = $param{OldStatus};
1520        if ( $old_status && $old_status eq MT::Entry::RELEASE() ) {
1521            $send_updates = 0;
1522        }
1523    }
1524
1525    if ( $send_updates && !( MT->config->DisableNotificationPings ) ) {
1526        ## Send update pings.
1527        my @updates = $mt->update_ping_list($blog);
1528        for my $url (@updates) {
1529            require MT::XMLRPC;
1530            if ( MT::XMLRPC->ping_update( 'weblogUpdates.ping', $blog, $url ) )
1531            {
1532                push @res, { good => 1, url => $url, type => "update" };
1533            }
1534            else {
1535                push @res,
1536                  {
1537                    good  => 0,
1538                    url   => $url,
1539                    type  => "update",
1540                    error => MT::XMLRPC->errstr
1541                  };
1542            }
1543        }
1544        if ( $blog->mt_update_key ) {
1545            require MT::XMLRPC;
1546            if ( MT::XMLRPC->mt_ping($blog) ) {
1547                push @res,
1548                  {
1549                    good => 1,
1550                    url  => $mt->{cfg}->MTPingURL,
1551                    type => "update"
1552                  };
1553            }
1554            else {
1555                push @res,
1556                  {
1557                    good  => 0,
1558                    url   => $mt->{cfg}->MTPingURL,
1559                    type  => "update",
1560                    error => MT::XMLRPC->errstr
1561                  };
1562            }
1563        }
1564    }
1565
1566    my $cfg     = $mt->{cfg};
1567    my $send_tb = $cfg->OutboundTrackbackLimit;
1568    return \@res if $send_tb eq 'off';
1569
1570    my @tb_domains;
1571    if ( $send_tb eq 'selected' ) {
1572        @tb_domains = $cfg->OutboundTrackbackDomains;
1573    }
1574    elsif ( $send_tb eq 'local' ) {
1575        my $iter = MT::Blog->load_iter();
1576        while ( my $b = $iter->() ) {
1577            next if $b->id == $blog->id;
1578            push @tb_domains, MT::Util::extract_domains( $b->site_url );
1579        }
1580    }
1581    my $tb_domains;
1582    if (@tb_domains) {
1583        $tb_domains = '';
1584        my %seen;
1585        local $_;
1586        foreach (@tb_domains) {
1587            next unless $_;
1588            $_ = lc($_);
1589            next if $seen{$_};
1590            $tb_domains .= '|' if $tb_domains ne '';
1591            $tb_domains .= quotemeta($_);
1592            $seen{$_} = 1;
1593        }
1594        $tb_domains = '(' . $tb_domains . ')' if $tb_domains;
1595    }
1596
1597    ## Send TrackBack pings.
1598    if ( my $entry = $param{Entry} ) {
1599        my $pings = $entry->to_ping_url_list;
1600
1601        my %pinged = map { $_ => 1 } @{ $entry->pinged_url_list };
1602        my $cats = $entry->categories;
1603        for my $cat (@$cats) {
1604            push @$pings, grep !$pinged{$_}, @{ $cat->ping_url_list };
1605        }
1606
1607        my $ua = MT->new_ua;
1608
1609        ## Build query string to be sent on each ping.
1610        my @qs;
1611        push @qs, 'title=' . MT::Util::encode_url( $entry->title );
1612        push @qs, 'url=' . MT::Util::encode_url( $entry->permalink );
1613        push @qs, 'excerpt=' . MT::Util::encode_url( $entry->get_excerpt );
1614        push @qs, 'blog_name=' . MT::Util::encode_url( $blog->name );
1615        my $qs = join '&', @qs;
1616
1617        ## Character encoding--best guess.
1618        my $enc = $mt->{cfg}->PublishCharset;
1619
1620        for my $url (@$pings) {
1621            $url =~ s/^\s*//;
1622            $url =~ s/\s*$//;
1623            my $url_domain;
1624            ($url_domain) = MT::Util::extract_domains($url);
1625            next if $tb_domains && lc($url_domain) !~ m/$tb_domains$/;
1626
1627            my $req = HTTP::Request->new( POST => $url );
1628            $req->content_type(
1629                "application/x-www-form-urlencoded; charset=$enc");
1630            $req->content($qs);
1631            my $res = $ua->request($req);
1632            if ( substr( $res->code, 0, 1 ) eq '2' ) {
1633                my $c = $res->content;
1634                my ( $error, $msg ) =
1635                  $c =~ m!<error>(\d+).*<message>(.+?)</message>!s;
1636                if ($error) {
1637                    push @res,
1638                      {
1639                        good  => 0,
1640                        url   => $url,
1641                        type  => 'trackback',
1642                        error => $msg
1643                      };
1644                }
1645                else {
1646                    push @res, { good => 1, url => $url, type => 'trackback' };
1647                }
1648            }
1649            else {
1650                push @res,
1651                  {
1652                    good  => 0,
1653                    url   => $url,
1654                    type  => 'trackback',
1655                    error => "HTTP error: " . $res->status_line
1656                  };
1657            }
1658        }
1659    }
1660    \@res;
1661}
1662
1663sub ping_and_save {
1664    my $mt    = shift;
1665    my %param = @_;
1666    if ( my $entry = $param{Entry} ) {
1667        my $results = MT::ping( $mt, @_ ) or return;
1668        my %still_ping;
1669        my $pinged = $entry->pinged_url_list;
1670        for my $res (@$results) {
1671            next if $res->{type} ne 'trackback';
1672            if ( !$res->{good} ) {
1673                $still_ping{ $res->{url} } = 1;
1674            }
1675            push @$pinged,
1676              $res->{url}
1677              . ( $res->{good}
1678                ? ''
1679                : ' ' . MT::I18N::encode_text( $res->{error} ) );
1680        }
1681        $entry->pinged_urls( join "\n", @$pinged );
1682        $entry->to_ping_urls( join "\n", keys %still_ping );
1683        $entry->save or return $mt->error( $entry->errstr );
1684        return $results;
1685    }
1686    1;
1687}
1688
1689sub needs_ping {
1690    my $mt    = shift;
1691    my %param = @_;
1692    my $blog  = $param{Blog};
1693    my $entry = $param{Entry};
1694    require MT::Entry;
1695    return unless $entry->status == MT::Entry::RELEASE();
1696    my $old_status = $param{OldStatus};
1697    my %list;
1698    ## If this is a new entry (!$old_status) OR the status was previously
1699    ## set to draft, and is now set to publish, send the update pings.
1700    if ( ( !$old_status || $old_status ne MT::Entry::RELEASE() )
1701        && !( MT->config->DisableNotificationPings ) )
1702    {
1703        my @updates = $mt->update_ping_list($blog);
1704        @list{@updates} = (1) x @updates;
1705        $list{ $mt->{cfg}->MTPingURL } = 1 if $blog && $blog->mt_update_key;
1706    }
1707    if ($entry) {
1708        @list{ @{ $entry->to_ping_url_list } } = ();
1709        my %pinged = map { $_ => 1 } @{ $entry->pinged_url_list };
1710        my $cats = $entry->categories;
1711        for my $cat (@$cats) {
1712            @list{ grep !$pinged{$_}, @{ $cat->ping_url_list } } = ();
1713        }
1714    }
1715    my @list = keys %list;
1716    return unless @list;
1717    \@list;
1718}
1719
1720sub update_ping_list {
1721    my $mt = shift;
1722    my ($blog) = @_;
1723
1724    my @updates;
1725    if ( my $pings = MT->registry('ping_servers') ) {
1726        my $up = $blog->update_pings;
1727        if ($up) {
1728            foreach ( split ',', $up ) {
1729                next unless exists $pings->{$_};
1730                push @updates, $pings->{$_}->{url};
1731            }
1732        }
1733    }
1734    if ( my $others = $blog->ping_others ) {
1735        push @updates, split /\r?\n/, $others;
1736    }
1737    my %updates;
1738    for my $url (@updates) {
1739        for ($url) {
1740            s/^\s*//;
1741            s/\s*$//;
1742        }
1743        next unless $url =~ /\S/;
1744        $updates{$url}++;
1745    }
1746    keys %updates;
1747}
1748
1749{
1750    my $LH;
1751
1752    sub set_language {
1753        my $pkg = shift;
1754        require MT::L10N;
1755        $LH = MT::L10N->get_handle(@_);
1756
1757        # Clear any l10n_handles in request
1758        $pkg->request( 'l10n_handle', {} );
1759        return $LH;
1760    }
1761
1762    require MT::I18N;
1763
1764    sub translate {
1765        my $this = shift;
1766        my $app = ref($this) ? $this : $this->app;
1767        if ( $app->{component} ) {
1768            if ( my $c = $app->component( $app->{component} ) ) {
1769                local $app->{component} = undef;
1770                return $c->translate(@_);
1771            }
1772        }
1773        my ( $format, @args ) = @_;
1774        foreach (@args) {
1775            $_ = $_->() if ref($_) eq 'CODE';
1776        }
1777        my $enc = MT->instance->config('PublishCharset') || 'utf-8';
1778        return $LH->maketext( $format, @args ) if $enc =~ m/utf-?8/i;
1779        $format = MT::I18N::encode_text( $format, $enc, 'utf-8' );
1780        MT::I18N::encode_text(
1781            $LH->maketext(
1782                $format,
1783                map { MT::I18N::encode_text( $_, $enc, 'utf-8' ) } @args
1784            ),
1785            'utf-8', $enc
1786        );
1787    }
1788
1789    sub translate_templatized {
1790        my $mt = shift;
1791        my $app = ref($mt) ? $mt : $mt->app;
1792        if ( $app->{component} ) {
1793            if ( my $c = $app->component( $app->{component} ) ) {
1794                local $app->{component} = undef;
1795                return $c->translate_templatized(@_);
1796            }
1797        }
1798        my @cstack;
1799        my ($text) = @_;
1800        while (1) {
1801            $text =~ s!(<(/)?(?:_|MT)_TRANS(_SECTION)?(?:(?:\s+((?:\w+)\s*=\s*(["'])(?:(<(?:[^"'>]|"[^"]*"|'[^']*')+)?>|[^\5]+?)*?\5))+?\s*/?)?>)!
1802            my($msg, $close, $section, %args) = ($1, $2, $3);
1803            while ($msg =~ /\b(\w+)\s*=\s*(["'])((?:<(?:[^"'>]|"[^"]*"|'[^']*')+?>|[^\2])*?)?\2/g) {  #"
1804                $args{$1} = $3;
1805            }
1806            if ($section) {
1807                if ($close) {
1808                    $mt = pop @cstack;
1809                } else {
1810                    if ($args{component}) {
1811                        push @cstack, $mt;
1812                        $mt = MT->component($args{component})
1813                            or die "Bad translation component: $args{component}";
1814                    }
1815                    else {
1816                        die "__trans_section without a component argument";
1817                    }
1818                }
1819                '';
1820            }
1821            else {
1822                $args{params} = '' unless defined $args{params};
1823                my @p = map MT::Util::decode_html($_),
1824                        split /\s*%%\s*/, $args{params}, -1;
1825                @p = ('') unless @p;
1826                my $translation = $mt->translate($args{phrase}, @p);
1827                if (exists $args{escape}) {
1828                    if (lc($args{escape}) eq 'html') {
1829                        $translation = MT::Util::encode_html($translation);
1830                    } elsif (lc($args{escape}) eq 'url') {
1831                        $translation = MT::Util::encode_url($translation);
1832                    } else {
1833                        # fallback for js/javascript/singlequotes
1834                        $translation = MT::Util::encode_js($translation);
1835                    }
1836                }
1837                $translation;
1838            }
1839            !igem or last;
1840        }
1841        return $text;
1842    }
1843
1844    sub current_language { $LH->language_tag }
1845    sub language_handle  { $LH }
1846
1847    sub charset {
1848        my $mt = shift;
1849        $mt->{charset} = shift if @_;
1850        return $mt->{charset} if $mt->{charset};
1851        $mt->{charset} = $mt->config->PublishCharset
1852          || $mt->language_handle->encoding;
1853    }
1854}
1855
1856sub supported_languages {
1857    my $mt = shift;
1858    require MT::L10N;
1859    require File::Basename;
1860    ## Determine full path to lib/MT/L10N directory...
1861    my $lib =
1862      File::Spec->catdir( File::Basename::dirname( $INC{'MT/L10N.pm'} ),
1863        'L10N' );
1864    ## ... From that, determine full path to extlib/MT/L10N.
1865    ## To do that, we look for the last instance of the string 'lib'
1866    ## in $lib and replace it with 'extlib'. reverse is a nice tricky
1867    ## way of doing that.
1868    ( my $extlib = reverse $lib ) =~ s!bil!biltxe!;
1869    $extlib = reverse $extlib;
1870    my @dirs = ( $lib, $extlib );
1871    my %langs;
1872    for my $dir (@dirs) {
1873        opendir DH, $dir or next;
1874        for my $f ( readdir DH ) {
1875            my ($tag) = $f =~ /^(\w+)\.pm$/;
1876            next unless $tag;
1877            my $lh = MT::L10N->get_handle($tag);
1878            $langs{ $lh->language_tag } = $lh->language_name;
1879        }
1880        closedir DH;
1881    }
1882    \%langs;
1883}
1884
1885# For your convenience
1886sub trans_error {
1887    my $app = shift;
1888    $app->error( $app->translate(@_) );
1889}
1890
1891sub all_text_filters {
1892    unless (%Text_filters) {
1893        if ( my $filters = MT->registry('text_filters') ) {
1894            %Text_filters = %$filters if ref($filters) eq 'HASH';
1895        }
1896    }
1897    if (my $enabled_filters = MT->config('AllowedTextFilters')) {
1898        my %enabled = map { $_ => 1 } split /\s*,\s*/, $enabled_filters;
1899        %Text_filters = map { $_ => $Text_filters{$_} }
1900                        grep { exists $enabled{$_} }
1901                        keys %Text_filters;
1902    }
1903    return \%Text_filters;
1904}
1905
1906sub apply_text_filters {
1907    my $mt = shift;
1908    my ( $str, $filters, @extra ) = @_;
1909    my $all_filters = $mt->all_text_filters;
1910    for my $filter (@$filters) {
1911        my $f = $all_filters->{$filter} or next;
1912        my $code = $f->{code} || $f->{handler};
1913        unless ( ref($code) eq 'CODE' ) {
1914            $code = $mt->handler_to_coderef($code);
1915            $f->{code} = $code;
1916        }
1917        if ( !$code ) {
1918            warn "Bad text filter: $filter";
1919            next;
1920        }
1921        $str = $code->( $str, @extra );
1922    }
1923    return $str;
1924}
1925
1926sub static_path {
1927    my $app = shift;
1928    my $spath = $app->config->StaticWebPath;
1929    if (!$spath) {
1930        $spath = $app->config->CGIPath;
1931        $spath .= '/' unless $spath =~ m!/$!;
1932        $spath .= 'mt-static/';
1933    } else {
1934        $spath .= '/' unless $spath =~ m!/$!;
1935    }
1936    $spath;
1937}
1938
1939sub static_file_path {
1940    my $app = shift;
1941    return $app->{__static_file_path}
1942        if exists $app->{__static_file_path};
1943
1944    my $path = $app->config('StaticFilePath');
1945    return $app->{__static_file_path} = $path if defined $path;
1946
1947    # Attempt to derive StaticFilePath based on environment
1948    my $web_path = $app->config->StaticWebPath || 'mt-static';
1949    $web_path =~ s!^https?://[^/]+/!!;
1950    if ($app->can('document_root')) {
1951        my $doc_static_path = File::Spec->catdir($app->document_root(), $web_path);
1952        return $app->{__static_file_path} = $doc_static_path
1953            if -d $doc_static_path;
1954    }
1955    my $mtdir_static_path = File::Spec->catdir($app->mt_dir, 'mt-static');
1956    return $app->{__static_file_path} = $mtdir_static_path
1957        if -d $mtdir_static_path;
1958    return;
1959}
1960
1961sub template_paths {
1962    my $mt = shift;
1963    my @paths;
1964    my $path = $mt->config->TemplatePath;
1965    if ($mt->{plugin_template_path}) {
1966        if (File::Spec->file_name_is_absolute($mt->{plugin_template_path})) {
1967            push @paths, $mt->{plugin_template_path}
1968                if -d $mt->{plugin_template_path};
1969        } else {
1970            my $dir = File::Spec->catdir($mt->app_dir,
1971                                         $mt->{plugin_template_path}); 
1972            if (-d $dir) {
1973                push @paths, $dir;
1974            } else {
1975                $dir = File::Spec->catdir($mt->mt_dir,
1976                                          $mt->{plugin_template_path});
1977                push @paths, $dir if -d $dir;
1978            }
1979        }
1980    }
1981    if (my $alt_path = $mt->config->AltTemplatePath) {
1982        if (-d $alt_path) {    # AltTemplatePath is absolute
1983            push @paths, File::Spec->catdir($alt_path,
1984                                            $mt->{template_dir})
1985                if $mt->{template_dir};
1986            push @paths, $alt_path;
1987        }
1988    }
1989 
1990    for my $addon ( @{ $mt->find_addons('pack') } ) {
1991        push @paths, File::Spec->catdir($addon->{path}, 'tmpl', $mt->{template_dir})
1992            if $mt->{template_dir};
1993        push @paths, File::Spec->catdir($addon->{path}, 'tmpl');
1994    }
1995
1996    push @paths, File::Spec->catdir($path, $mt->{template_dir})
1997        if $mt->{template_dir};
1998    push @paths, $path;
1999 
2000    return @paths;
2001}
2002
2003sub find_file {
2004    my $mt = shift;
2005    my ($paths, $file) = @_;
2006    my $filename;
2007    foreach my $p (@$paths) {
2008        my $filepath = File::Spec->canonpath(File::Spec->catfile($p, $file));
2009        $filename = File::Spec->canonpath($filepath);
2010        return $filename if -f $filename;
2011    }
2012    undef;
2013}
2014
2015sub load_tmpl {
2016    my $mt = shift;
2017    if ( exists($mt->{component}) && ( $mt->{component} ne 'Core' ) ) {
2018        if (my $c = $mt->component($mt->{component})) {
2019            return $c->load_tmpl(@_);
2020        }
2021    }
2022
2023    my($file, @p) = @_;
2024    my $param;
2025    if (@p && (ref($p[$#p]) eq 'HASH')) {
2026        $param = pop @p;
2027    }
2028    my $cfg = $mt->config;
2029    require MT::Template;
2030    my $tmpl;
2031    my @paths = $mt->template_paths;
2032
2033    my $type = {'SCALAR' => 'scalarref', 'ARRAY' => 'arrayref'}->{ref $file}
2034        || 'filename';
2035    $tmpl = MT::Template->new(
2036        type => $type, source => $file,
2037        path => \@paths,
2038        filter => sub {
2039            my ($str, $fname) = @_;
2040            if ($fname) {
2041                $fname = File::Basename::basename($fname);
2042                $fname =~ s/\.tmpl$//;
2043                $mt->run_callbacks("template_source.$fname", $mt, @_);
2044            } else {
2045                $mt->run_callbacks("template_source", $mt, @_);
2046            }
2047            return $str;
2048        },
2049        @p);
2050    return $mt->error(
2051        $mt->translate("Loading template '[_1]' failed.", $file)) unless $tmpl;
2052    $mt->set_default_tmpl_params($tmpl);
2053    $tmpl->param($param) if $param;
2054    $tmpl;
2055}
2056
2057sub set_default_tmpl_params {
2058    my $mt = shift;
2059    my ($tmpl) = @_;
2060    my $param = {};
2061    $param->{mt_debug} = $MT::DebugMode;
2062    $param->{mt_beta} = 1 if MT->version_id =~ m/^\d+\.\d+(?:a|b|rc)/;
2063    $param->{static_uri} = $mt->static_path;
2064    $param->{mt_version} = MT->version_number;
2065    $param->{mt_version_id} = MT->version_id;
2066    $param->{mt_product_code} = MT->product_code;
2067    $param->{mt_product_name} = $mt->translate(MT->product_name);
2068    $param->{language_tag} = substr($mt->current_language, 0, 2);
2069    $param->{language_encoding} = $mt->charset;
2070    if ($mt->isa('MT::App')) {
2071        if (my $author = $mt->user) {
2072            $param->{author_id} = $author->id;
2073            $param->{author_name} = $author->name;
2074        }
2075        ## We do this in load_tmpl because show_error and login don't call
2076        ## build_page; so we need to set these variables here.
2077        require MT::Auth;
2078        $param->{can_logout} = MT::Auth->can_logout;
2079        $param->{script_url} = $mt->uri;
2080        $param->{mt_url} = $mt->mt_uri;
2081        $param->{script_path} = $mt->path;
2082        $param->{script_full_url} = $mt->base . $mt->uri;
2083        $param->{agent_mozilla} = ( $ENV{HTTP_USER_AGENT} || '' ) =~ /gecko/i;
2084        $param->{agent_ie} = ( $ENV{HTTP_USER_AGENT} || '' ) =~ /\bMSIE\b/;
2085    }
2086    if (!$tmpl->param('template_filename')) {
2087        if (my $fname = $tmpl->{__file}) {
2088            $fname =~ s!\\!/!g;
2089            $fname =~ s/\.tmpl$//;
2090            $param->{template_filename} = $fname;
2091        }
2092    }
2093    $tmpl->param($param);
2094}
2095
2096sub process_mt_template {
2097    my $mt = shift;
2098    my ($body) = @_;
2099    $body =~ s@<(?:_|MT)_ACTION\s+mode="([^"]+)"(?:\s+([^>]*))?>@
2100        my $mode = $1; my %args;
2101        %args = $2 =~ m/\s*(\w+)="([^"]*?)"\s*/g if defined $2; # "
2102        MT::Util::encode_html($mt->uri(mode => $mode, args => \%args));
2103    @geis;
2104    # Strip out placeholder wrappers to facilitate tmpl_* callbacks
2105    $body =~ s/<\/?MT_(\w+):(\w+)>//g;
2106    $body;
2107}
2108
2109sub build_page {
2110    my $mt = shift;
2111    my($file, $param) = @_;
2112    my $tmpl;
2113    my $mode = $mt->mode;
2114    $param->{"mode_$mode"} ||= 1;
2115    $param->{breadcrumbs} = $mt->{breadcrumbs};
2116    if ($param->{breadcrumbs}[-1]) {
2117        $param->{breadcrumbs}[-1]{is_last} = 1;
2118        $param->{page_titles} = [ reverse @{ $mt->{breadcrumbs} } ];
2119    }
2120    pop @{ $param->{page_titles} };
2121    if (my $lang_id = $mt->current_language) {
2122        $param->{local_lang_id} ||= lc $lang_id;
2123    }
2124    $param->{magic_token} = $mt->current_magic if $mt->user;
2125
2126    # List of installed packs in the application footer
2127    my @packs_installed;
2128    my $packs = $mt->find_addons('pack');
2129    if ($packs) {
2130        foreach my $pack (@$packs) {
2131            my $c = $mt->component(lc $pack->{id});
2132            if ($c) {
2133                my $label = $c->label || $pack->{label};
2134                $label = $label->() if ref($label) eq 'CODE';
2135                push @packs_installed, {
2136                    label => $label,
2137                    version => $c->version,
2138                    id => $c->id,
2139                };
2140            }
2141        }
2142    }
2143    @packs_installed = sort { $a->{label} cmp $b->{label} } @packs_installed;
2144    $param->{packs_installed} = \@packs_installed;
2145   
2146    require MT::I18N;
2147    $param->{portal_url} = MT::I18N::const('PORTAL_URL');
2148
2149    for my $config_field (keys %{ MT::ConfigMgr->instance->{__var} || {} }) {
2150        $param->{ $config_field . '_readonly' } = 1;
2151    }
2152
2153    my $tmpl_file = '';
2154    if (UNIVERSAL::isa($file, 'MT::Template')) {
2155        $tmpl = $file;
2156        $tmpl_file = (exists $file->{__file}) ? $file->{__file} : '';
2157    } else {
2158        $tmpl = $mt->load_tmpl($file) or return;
2159        $tmpl_file = $file unless ref($file);
2160    }
2161
2162    if (($mode && ($mode !~ m/delete/)) && ($mt->{login_again} ||
2163        ($mt->{requires_login} && !$mt->user))) {
2164        ## If it's a login screen, direct the user to where they were going
2165        ## (query params including mode and all) unless they were logging in,
2166        ## logging out, or deleting something.
2167        my $q = $mt->{query};
2168        if ($mode) {
2169            my @query = map { { name => $_, value => scalar encode_text( $q->param($_) ) }; }
2170                grep { ($_ ne 'username') && ($_ ne 'password') && ($_ ne 'submit') && ($mode eq 'logout' ? ($_ ne '__mode') : 1) } $q->param;
2171            $param->{query_params} = \@query;
2172        }
2173        $param->{login_again} = $mt->{login_again};
2174    }
2175
2176    my $blog = $mt->blog;
2177    $tmpl->context()->stash('blog', $blog) if $blog;
2178
2179    $tmpl->param($param) if $param;
2180
2181    if ($tmpl_file) {
2182        $tmpl_file = File::Basename::basename($tmpl_file);
2183        $tmpl_file =~ s/\.tmpl$//;
2184        $tmpl_file = '.' . $tmpl_file;
2185    }
2186    $mt->run_callbacks('template_param' . $tmpl_file, $mt, $tmpl->param, $tmpl);
2187
2188    my $output = $mt->build_page_in_mem($tmpl);
2189    return unless defined $output;
2190
2191    $mt->run_callbacks('template_output' . $tmpl_file, $mt, \$output, $tmpl->param, $tmpl);
2192    return $output;
2193}
2194
2195sub build_page_in_mem {
2196    my $mt = shift;
2197    my($tmpl, $param) = @_;
2198    $tmpl->param($param) if $param;
2199    my $out = $tmpl->output;
2200    return $mt->error($tmpl->errstr) unless defined $out;
2201    return $mt->translate_templatized($mt->process_mt_template($out));
2202}
2203
2204sub new_ua {
2205    my $class = shift;
2206    my ($opt) = @_;
2207    $opt ||= {};
2208    my $lwp_class = 'LWP::UserAgent';
2209    if ($opt->{paranoid}) {
2210        eval { require LWPx::ParanoidAgent; };
2211        $lwp_class = 'LWPx::ParanoidAgent' unless $@;
2212    }
2213    eval "require $lwp_class;";
2214    return undef if $@;
2215    my $cfg = $class->config;
2216    my $max_size = exists $opt->{max_size} ? $opt->{max_size} : 100_000;
2217    my $timeout = exists $opt->{timeout} ? $opt->{timeout} : $cfg->HTTPTimeout || $cfg->PingTimeout;
2218    my $proxy = exists $opt->{proxy} ? $opt->{proxy} : $cfg->HTTPProxy || $cfg->PingProxy;
2219    my $no_proxy = exists $opt->{no_proxy} ? $opt->{no_proxy} : $cfg->HTTPNoProxy || $cfg->PingNoProxy;
2220    my $agent = $opt->{agent} || 'MovableType/' . $MT::VERSION;
2221    my $interface = exists $opt->{interface} ? $opt->{interface} : $cfg->HTTPInterface || $cfg->PingInterface;
2222
2223    if ( my $localaddr = $interface ) {
2224        @LWP::Protocol::http::EXTRA_SOCK_OPTS = (
2225            LocalAddr => $localaddr,
2226            Reuse     => 1
2227        );
2228    }
2229
2230    my $ua = $lwp_class->new;
2231    $ua->max_size($max_size) if (defined $max_size) && $ua->can('max_size');
2232    $ua->agent( $agent );
2233    $ua->timeout( $timeout ) if defined $timeout;
2234    if ( defined $proxy ) {
2235        $ua->proxy( http => $proxy );
2236        my @domains = split( /,\s*/, $no_proxy ) if $no_proxy;
2237        $ua->no_proxy(@domains) if @domains;
2238    }
2239    return $ua;
2240}
2241
2242sub build_email {
2243    my $class = shift;
2244    my ( $file, $param ) = @_;
2245    my $mt = $class->instance;
2246
2247    # basically, try to load from database
2248    my $blog = $param->{blog} || undef;
2249    my $id = $file;
2250    $id =~ s/(\.tmpl|\.mtml)$//;
2251
2252    require MT::Template;
2253    my @tmpl = MT::Template->load(
2254        {
2255            ( $blog ? ( blog_id => [ $blog->id, 0 ] ) : ( blog_id => 0 ) ),
2256            identifier => $id,
2257            type       => 'email',
2258        }
2259    );
2260    my $tmpl =
2261      @tmpl
2262      ? (
2263        scalar @tmpl > 1
2264        ? ( $tmpl[0]->blog_id ? $tmpl[0] : $tmpl[1] )
2265        : $tmpl[0]
2266      )
2267      : undef;
2268
2269    # try to load from file
2270    unless ($tmpl) {
2271        local $mt->{template_dir} = 'email';
2272        $tmpl = $mt->load_tmpl($file);
2273    }
2274    return unless $tmpl;
2275
2276    my $ctx = $tmpl->context;
2277    $ctx->stash( 'blog_id', $blog->id ) if $blog;
2278    $ctx->stash( 'blog',   delete $param->{'blog'} )   if $param->{'blog'};
2279    $ctx->stash( 'entry',  delete $param->{'entry'} )  if $param->{'entry'};
2280    $ctx->stash( 'author', delete $param->{'author'} ) if $param->{'author'};
2281    $ctx->stash( 'commenter', delete $param->{'commenter'} )
2282      if $param->{'commenter'};
2283    $ctx->stash( 'comment', delete $param->{'comment'} ) if $param->{'comment'};
2284    $ctx->stash( 'category', delete $param->{'category'} )
2285      if $param->{'category'};
2286    $ctx->stash( 'ping', delete $param->{'ping'} ) if $param->{'ping'};
2287
2288    foreach my $p (%$param) {
2289        if ( ref($p) ) {
2290            $tmpl->param( $p, $param->{$p} );
2291        }
2292    }
2293    return $mt->build_page_in_mem( $tmpl, $param );
2294}
2295
2296sub get_next_sched_post_for_user {
2297    my ( $author_id, @further_blog_ids ) = @_;
2298    require MT::Permission;
2299    my @perms = MT::Permission->load( { author_id => $author_id }, {} );
2300    my @blogs = @further_blog_ids;
2301    for my $perm (@perms) {
2302        next
2303          unless ( $perm->can_edit_config
2304            || $perm->can_publish_post
2305            || $perm->can_edit_all_posts );
2306        push @blogs, $perm->blog_id;
2307    }
2308    my $next_sched_utc = undef;
2309    require MT::Entry;
2310    for my $blog_id (@blogs) {
2311        my $blog           = MT::Blog->load($blog_id)
2312            or next;
2313        my $earliest_entry = MT::Entry->load(
2314            {
2315                status  => MT::Entry::FUTURE(),
2316                blog_id => $blog_id
2317            },
2318            { 'sort' => 'created_on' }
2319        );
2320        if ($earliest_entry) {
2321            my $entry_utc =
2322              MT::Util::ts2iso( $blog, $earliest_entry->created_on );
2323            if ( $entry_utc < $next_sched_utc || !defined($next_sched_utc) ) {
2324                $next_sched_utc = $entry_utc;
2325            }
2326        }
2327    }
2328    return $next_sched_utc;
2329}
2330
2331our %Commenter_Auth;
2332
2333sub init_commenter_authenticators {
2334    my $self = shift;
2335    my $auths = $self->registry("commenter_authenticators") || {};
2336    foreach my $auth ( keys %$auths ) {
2337        delete $auths->{$auth}
2338          if exists( $auths->{$auth}->{condition} )
2339          && !( $auths->{$auth}->{condition}->() );
2340    }
2341    %Commenter_Auth = %$auths;
2342    $Commenter_Auth{$_}{key} ||= $_ for keys %Commenter_Auth;
2343}
2344
2345sub commenter_authenticator {
2346    my $self = shift;
2347    my ($key) = @_;
2348    %Commenter_Auth or $self->init_commenter_authenticators();
2349    return $Commenter_Auth{$key};
2350}
2351
2352sub commenter_authenticators {
2353    my $self = shift;
2354    %Commenter_Auth or $self->init_commenter_authenticators();
2355    return values %Commenter_Auth;
2356}
2357
2358sub _commenter_auth_params {
2359    my ( $key, $blog_id, $entry_id, $static ) = @_;
2360    my $params = {
2361        blog_id => $blog_id,
2362        static  => $static,
2363    };
2364    $params->{entry_id} = $entry_id if defined $entry_id;
2365    return $params;
2366}
2367
2368sub _openid_commenter_condition {
2369    eval "require Digest::SHA1;";
2370    return $@ ? 0 : 1;
2371}
2372
2373sub core_commenter_authenticators {
2374    return {
2375        'OpenID' => {
2376            class      => 'MT::Auth::OpenID',
2377            label      => 'OpenID',
2378            login_form => <<OpenID,
2379<form method="post" action="<mt:var name="script_url">">
2380<input type="hidden" name="__mode" value="login_external" />
2381<input type="hidden" name="blog_id" value="<mt:var name="blog_id">" />
2382<input type="hidden" name="entry_id" value="<mt:var name="entry_id">" />
2383<input type="hidden" name="static" value="<mt:var name="static" escape="html">" />
2384<fieldset>
2385<mtapp:setting
2386    id="openid_display"
2387    label="<__trans phrase="OpenID URL">"
2388    hint="<__trans phrase="Sign in using your OpenID identity.">">
2389<input type="hidden" name="key" value="OpenID" />
2390<input name="openid_url" style="background: #fff url('<mt:var name="static_uri">images/comment/openid_logo.png') no-repeat left; padding-left: 18px; padding-bottom: 1px; border: 1px solid #5694b6; width: 304px; font-size: 110%;" />
2391    <p class="hint"><__trans phrase="OpenID is an open and decentralized single sign-on identity system."></p>
2392</mtapp:setting>
2393<img src="<mt:var name="static_uri">images/comment/openid_enabled.png" class="right" />
2394<div class="actions-bar actions-bar-login">
2395    <div class="actions-bar-inner pkg actions">
2396        <button
2397            type="submit"
2398            class="primary-button"
2399            ><__trans phrase="Sign in"></button>
2400    </div>
2401</div>
2402<p><img src="<mt:var name="static_uri">images/comment/blue_moreinfo.png"> <a href="http://www.openid.net/"><__trans phrase="Learn more about OpenID."></a></p>
2403</fieldset>
2404</form>
2405OpenID
2406            login_form_params => \&_commenter_auth_params,
2407            condition         => \&_openid_commenter_condition,
2408            logo              => 'images/comment/signin_openid.png',
2409            logo_small        => 'images/comment/openid_logo.png',
2410        },
2411        'LiveJournal' => {
2412            class      => 'MT::Auth::LiveJournal',
2413            label      => 'LiveJournal',
2414            login_form => <<LiveJournal,
2415<form method="post" action="<mt:var name="script_url">">
2416<input type="hidden" name="__mode" value="login_external" />
2417<input type="hidden" name="blog_id" value="<mt:var name="blog_id">" />
2418<input type="hidden" name="entry_id" value="<mt:var name="entry_id">" />
2419<input type="hidden" name="static" value="<mt:var name="static" escape="html">" />
2420<input type="hidden" name="key" value="LiveJournal" />
2421<fieldset>
2422<mtapp:setting
2423    id="livejournal_display"
2424    label="<__trans phrase="Your LiveJournal Username">"
2425    hint="<__trans phrase="Sign in using your Vox blog URL">">
2426<input name="openid_userid" style="background: #fff url('<mt:var name="static_uri">images/comment/livejournal_logo.png') no-repeat 2px center; padding: 2px 2px 2px 20px; border: 1px solid #5694b6; width: 300px; font-size: 110%;" />
2427</mtapp:setting>
2428<div class="actions-bar actions-bar-login">
2429    <div class="actions-bar-inner pkg actions">
2430        <button
2431            type="submit"
2432            class="primary-button"
2433            ><__trans phrase="Sign in"></button>
2434    </div>
2435</div>
2436<p><img src="<mt:var name="static_uri">images/comment/blue_moreinfo.png"> <a href="http://www.livejournal.com/"><__trans phrase="Learn more about LiveJournal."></a></p>
2437</fieldset>
2438</form>
2439LiveJournal
2440            login_form_params => \&_commenter_auth_params,
2441            condition         => \&_openid_commenter_condition,
2442            logo              => 'images/comment/signin_livejournal.png',
2443            logo_small        => 'images/comment/livejournal_logo.png',
2444        },
2445        'Vox' => {
2446            class      => 'MT::Auth::Vox',
2447            label      => 'Vox',
2448            login_form => <<Vox,
2449<form method="post" action="<mt:var name="script_url">">
2450<input type="hidden" name="__mode" value="login_external" />
2451<input type="hidden" name="blog_id" value="<mt:var name="blog_id">" />
2452<input type="hidden" name="entry_id" value="<mt:var name="entry_id">" />
2453<input type="hidden" name="static" value="<mt:var name="static" escape="html">" />
2454<input type="hidden" name="key" value="Vox" />
2455<fieldset>
2456<mtapp:setting
2457    id="vox_display"
2458    label="<__trans phrase="Your Vox Blog URL">">
2459http:// <input name="openid_userid" style="background: #fff url('<mt:var name="static_uri">images/comment/vox_logo.png') no-repeat 2px center; padding: 2px 2px 2px 20px; border: 1px solid #5694b6; width: 200px; font-size: 110%; vertical-align: middle" />.vox.com
2460</mtapp:setting>
2461<div class="actions-bar actions-bar-login">
2462    <div class="actions-bar-inner pkg actions">
2463        <button
2464            type="submit"
2465            class="primary-button"
2466            ><__trans phrase="Sign in"></button>
2467    </div>
2468</div>
2469<p><img src="<mt:var name="static_uri">images/comment/blue_moreinfo.png"> <a href="http://www.vox.com/"><__trans phrase="Learn more about Vox."></a></p>
2470</fieldset>
2471</form>
2472Vox
2473            login_form_params => \&_commenter_auth_params,
2474            condition         => \&_openid_commenter_condition,
2475            logo              => 'images/comment/signin_vox.png',
2476            logo_small        => 'images/comment/vox_logo.png',
2477        },
2478        'TypeKey' => {
2479            class      => 'MT::Auth::TypeKey',
2480            label      => 'TypeKey',
2481            login_form => <<TypeKey,
2482<p class="hint"><__trans phrase="TypeKey is a free, open system providing you a central identity for posting comments on weblogs and logging into other websites. You can register for free."></p>
2483<p><img src="<mt:var name="static_uri">images/comment/blue_goto.png"> <a href="<mt:var name="tk_signin_url">"><__trans phrase="Sign in or register with TypeKey."></a></p>
2484TypeKey
2485            login_form_params => sub {
2486                my ( $key, $blog_id, $entry_id, $static ) = @_;
2487                my $entry = MT::Entry->load($entry_id) if $entry_id;
2488
2489                ## TypeKey URL
2490                require MT::Template::Context;
2491                my $ctx = MT::Template::Context->new;
2492                $ctx->stash( 'blog_id', $blog_id );
2493                my $blog = MT::Blog->load($blog_id);
2494                $ctx->stash( 'blog',  $blog );
2495                $ctx->stash( 'entry', $entry );
2496                my $params = {};
2497                $params->{tk_signin_url} =
2498                  MT::Template::Context::_hdlr_remote_sign_in_link( $ctx,
2499                    { static => $static } );
2500                return $params;
2501            },
2502            logo => 'images/comment/signin_typekey.png',
2503            logo_small        => 'images/comment/typekey_logo.png',
2504        },
2505    };
2506}
2507
2508our %Captcha_Providers;
2509
2510sub captcha_provider {
2511    my $self = shift;
2512    my ($key) = @_;
2513    $self->init_captcha_providers() unless %Captcha_Providers;
2514    return $Captcha_Providers{$key};
2515}
2516
2517sub captcha_providers {
2518    my $self = shift;
2519    $self->init_captcha_providers() unless %Captcha_Providers;
2520    my $def  = delete $Captcha_Providers{'mt_default'};
2521    my @vals = values %Captcha_Providers;
2522    if ( defined($def) && $def->{condition}->() ) {
2523        unshift @vals, $def;
2524    }
2525    @vals;
2526}
2527
2528sub core_captcha_providers {
2529    return {
2530        'mt_default' => {
2531            label     => 'Movable Type default',
2532            class     => 'MT::Util::Captcha',
2533            condition => sub {
2534                require MT::Util::Captcha;
2535                if ( my $error = MT::Util::Captcha->check_availability ) {
2536                    return 0;
2537                }
2538                1;
2539            },
2540        }
2541    };
2542}
2543
2544sub init_captcha_providers {
2545    my $self = shift;
2546    my $providers = $self->registry("captcha_providers") || {};
2547    foreach my $provider ( keys %$providers ) {
2548        delete $providers->{$provider}
2549          if exists(