root/branches/release-41/lib/MT.pm.pre @ 2667

Revision 2667, 106.1 kB (checked in by bchoate, 17 months ago)

Added support for a plugin/component to define an init handler.
  • Property svn:keywords set to Author Date Id Revision
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$
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 ) = ( '__API_VERSION__', '__SCHEMA_VERSION__' );
33    ( $PRODUCT_NAME, $PRODUCT_CODE, $PRODUCT_VERSION, $VERSION_ID ) = (
34        '__PRODUCT_NAME__',    '__PRODUCT_CODE__',
35        '__PRODUCT_VERSION__', '__PRODUCT_VERSION_ID__'
36    );
37
38    $DebugMode = 0;
39
40    # Alias lowercase to uppercase package; note: this is an equivalence
41    # as opposed to having @mt::ISA set to 'MT'. so @mt::Plugins would
42    # resolve as well as @MT::Plugins.
43    *{mt::} = *{MT::};
44
45    # Alias these; Components is the preferred array for MT 4
46    *Plugins = \@Components;
47}
48
49# On-demand loading of compatibility module, if a plugin asks for it, using
50#     use MT 3;
51# or even specific to minor version (but this just loads MT::Compat::v3)
52#     use MT 3.3;
53sub VERSION {
54    my $v = $_[1];
55    if ( defined $v && ( $v =~ m/^(\d+)/ ) ) {
56        my $compat = "MT::Compat::v" . $1;
57        if ( ( $1 > 2 ) && ( $1 < int($VERSION) ) ) {
58            no strict 'refs';
59            unless ( defined *{ $compat . '::' } ) {
60                eval "# line " . __LINE__ . " " . __FILE__ . "\nrequire $compat;";
61            }
62        }
63    }
64    return UNIVERSAL::VERSION(@_);
65}
66
67sub version_number  { $VERSION }
68sub version_id      { $VERSION_ID }
69sub product_code    { $PRODUCT_CODE }
70sub product_name    { $PRODUCT_NAME }
71sub product_version { $PRODUCT_VERSION }
72sub schema_version  { $SCHEMA_VERSION }
73
74# Default id method turns MT::App::CMS => cms; Foo::Bar => foo/bar
75sub id {
76    my $pkg = shift;
77    my $id = ref($pkg) || $pkg;
78    # ignore the MT::App prefix as part of the identifier
79    $id =~ s/^MT::App:://;
80    $id =~ s!::!/!g;
81    return lc $id;
82}
83
84sub version_slug {
85    return MT->translate_templatized(<<"SLUG");
86<MT_TRANS phrase="Powered by [_1]" params="$PRODUCT_NAME">
87<MT_TRANS phrase="Version [_1]" params="$VERSION_ID">
88<MT_TRANS phrase="http://www.sixapart.com/movabletype/">
89SLUG
90}
91
92sub import {
93    my $pkg = shift;
94    return unless @_;
95
96    my (%param) = @_;
97    my $app_pkg;
98    if ( $app_pkg = $param{app} || $param{App} || $ENV{MT_APP} ) {
99        if ( $app_pkg !~ m/::/ ) {
100            my $apps = $pkg->registry('applications');
101            $app_pkg = $apps->fetch($app_pkg);
102            if ( ref $app_pkg ) {
103
104                # pick first one??
105                $app_pkg = $app_pkg->[0];
106
107                # pick last one??
108                # $app_pkg = pop @$app_pkg;
109            }
110        }
111    }
112    elsif ( $param{run} || $param{Run} ) {
113
114        # my $script = File::Spec->rel2abs($0);
115        my ( $filename, $path, $suffix ) = fileparse( $0, qr{\..+$} );
116        $SCRIPT_SUFFIX = $suffix;
117        my $script = lc $filename;
118        $script =~ s/^mt-//;
119        my $apps = $pkg->registry('applications');
120        $app_pkg = $apps->fetch( lc $script );
121        unless ($app_pkg) {
122            die "cannot determine application for script $0, stopped at";
123        }
124    }
125    $pkg->run_app( $app_pkg, \%param )
126      if $app_pkg;
127}
128
129sub run_app {
130    my $pkg = shift;
131    my ( $class, $param ) = @_;
132
133    # When running under FastCGI, the initial invocation of the
134    # script has a bare environment. We can use this to test
135    # for FastCGI.
136    my $not_fast_cgi = 0;
137    $not_fast_cgi ||= exists $ENV{$_}
138      for qw(HTTP_HOST GATEWAY_INTERFACE SCRIPT_FILENAME SCRIPT_URL);
139    my $fast_cgi = ( !$not_fast_cgi ) || $param->{fastcgi};
140    $fast_cgi =
141      defined( $param->{fastcgi} || $param->{FastCGI} )
142      ? ( $param->{fastcgi} || $param->{FastCGI} )
143      : $fast_cgi;
144    if ($fast_cgi) {
145        eval { require CGI::Fast; };
146        $fast_cgi = 0 if $@;
147    }
148
149    # ready to run now... run inside an eval block so we can gracefully
150    # die if something bad happens
151    my $app;
152    eval {
153        eval "require $class; 1;" or die $@;
154        if ($fast_cgi) {
155            while ( my $cgi = new CGI::Fast ) {
156                $app = $class->new( %$param, CGIObject => $cgi )
157                  or die $class->errstr;
158                local $SIG{__WARN__} = sub { $app->trace( $_[0] ) };
159                $pkg->set_instance($app);
160                $app->init_request( CGIObject => $cgi );
161                $app->run;
162            }
163        }
164        else {
165            $app = $class->new(%$param) or die $class->errstr;
166            local $SIG{__WARN__} = sub { $app->trace( $_[0] ) };
167            $app->run;
168        }
169    };
170    if ( my $err = $@ ) {
171        my $charset = 'utf-8';
172        eval {
173            $app ||= MT->instance;
174            my $cfg = $app->config;
175            my $c   = $app->find_config;
176            $cfg->read_config($c);
177            $charset = $cfg->PublishCharset;
178        };
179        if ( $app && UNIVERSAL::isa( $app, 'MT::App' ) ) {
180            eval {
181                my %param = ( error => $err );
182                if ( $err =~ m/Bad ObjectDriver/ ) {
183                    $param{error_database_connection} = 1;
184                }
185                elsif ( $err =~ m/Bad CGIPath/ ) {
186                    $param{error_cgi_path} = 1;
187                }
188                elsif ( $err =~ m/Missing configuration file/ ) {
189                    $param{error_config_file} = 1;
190                }
191                my $page = $app->build_page( 'error.tmpl', \%param )
192                  or die $app->errstr;
193                print "Content-Type: text/html; charset=$charset\n\n";
194                print $page;
195            };
196            if ( my $err = $@ ) {
197                print "Content-Type: text/plain; charset=$charset\n\n";
198                print $app
199                  ? $app->translate( "Got an error: [_1]", $err )
200                  : "Got an error: $err";
201            }
202        }
203        else {
204            if ( $err =~ m/Missing configuration file/ ) {
205                my $host = $ENV{SERVER_NAME} || $ENV{HTTP_HOST};
206                $host =~ s/:\d+//;
207                my $port = $ENV{SERVER_PORT};
208                my $uri = $ENV{REQUEST_URI} || $ENV{PATH_INFO};
209                $uri =~ s/mt(\Q$SCRIPT_SUFFIX\E)?.*$//;
210                my $cgipath = '';
211                $cgipath = $port == 443 ? 'https' : 'http';
212                $cgipath .= '://' . $host;
213                $cgipath .= ( $port == 443 || $port == 80 ) ? '' : ':' . $port;
214                $cgipath .= $uri;
215
216                print "Status: 302 Moved\n";
217                print "Location: " . $cgipath . "mt-wizard.cgi\n\n";
218            }
219            else {
220                print "Content-Type: text/plain; charset=$charset\n\n";
221                print $app
222                  ? $app->translate( "Got an error: [_1]", $err )
223                  : "Got an error: $err\n";
224            }
225        }
226    }
227}
228
229sub app {
230    my $class = shift;
231    $mt_inst ||= $mt_inst{$class} ||= $class->construct(@_);
232}
233*instance = *app;
234
235sub set_instance {
236    my $class = shift;
237    $mt_inst = shift;
238}
239
240sub new {
241    my $mt = &instance_of;
242    $mt_inst ||= $mt;
243    $mt;
244}
245
246sub instance_of {
247    my $class = shift;
248    $mt_inst{$class} ||= $class->construct(@_);
249}
250
251sub construct {
252    my $class = shift;
253    my $mt = bless {}, $class;
254    local $mt_inst = $mt;
255    $mt->init(@_)
256      or die $mt->errstr;
257    $mt;
258}
259
260{
261    my %object_types;
262
263    sub model {
264        my $pkg = shift;
265        my ($k) = @_;
266        $object_types{$k} = $_[1] if scalar @_ > 1;
267        return $object_types{$k} if exists $object_types{$k};
268
269        if ($k =~ m/^(.+):meta$/) {
270            my $ppkg = $pkg->model($1);
271            my $mpkg = $ppkg->meta_pkg;
272            return $mpkg ? $object_types{$k} = $mpkg : undef;
273        }
274
275        my $model = $pkg->registry( 'object_types', $k );
276        if ( ref($model) eq 'ARRAY' ) {
277
278            # First element of an array *should* be a scalar; in case it isn't,
279            # return undef.
280            $model = $model->[0];
281            return undef if ref $model;
282        }
283        elsif ( ref($model) eq 'HASH' ) {
284
285            # If all we have is a hash, this doesn't tell us the package for
286            # this object type, so it's undefined.
287            return undef;
288        }
289        return undef unless $model;
290
291        # Element in object type hash is scalar, so return it
292        no strict 'refs';
293        unless ( defined *{ $model . '::__properties' } ) {
294            use strict 'refs';
295            eval "# line " . __LINE__ . " " . __FILE__ . "\nrequire $model;";
296            if ( $@ && ( $k =~ m/^(.+)\./ ) ) {
297
298                # x.foo can't be found, so try loading x
299                if ( my $ppkg = $pkg->model($1) ) {
300
301                    # well now see if $model is defined
302                    no strict 'refs';
303                    unless ( defined *{ $model . '::__properties' } ) {
304
305                        # if not, use parent package instead
306                        $model = $ppkg;
307                    }
308                }
309            }
310        }
311        return $object_types{$k} = $model;
312    }
313
314    sub models {
315        my $pkg = shift;
316        my ($k) = @_;
317
318        my @matches;
319        my $model = $pkg->registry('object_types');
320        foreach my $m ( keys %$model ) {
321            if ( $m =~ m/^\Q$k\E\.?/ ) {
322                push @matches, $m;
323            }
324        }
325        return @matches;
326    }
327}
328
329sub registry {
330    my $pkg = shift;
331
332    # if (!ref $pkg) {
333    #     return $pkg->instance->registry(@_);
334    # }
335    require MT::Component;
336    my $regs = MT::Component->registry(@_);
337    my $r;
338    if ($regs) {
339        foreach my $cr (@$regs) {
340
341            # in the event that our registry request returns something
342            # other than an array of hashes, return it as is instead of
343            # merging it together.
344            return $regs unless ref($cr) eq 'HASH';
345
346            # next unless ref($cr) eq 'HASH';
347            delete $cr->{plugin} if exists $cr->{plugin};
348            __merge_hash( $r ||= {}, $cr );
349        }
350    }
351    return $r;
352}
353
354# merges contents of two hashes, giving preference to the right side
355# if $replace is true; otherwise it will always append to the left side.
356sub __merge_hash {
357    my ( $h1, $h2, $replace ) = @_;
358    for my $k ( keys(%$h2) ) {
359        if ( exists( $h1->{$k} ) && ( !$replace ) ) {
360            if ( ref $h1->{$k} eq 'HASH' ) {
361                __merge_hash( $h1->{$k}, $h2->{$k}, ( $replace || 0 ) + 1 );
362            }
363            elsif ( ref $h1->{$k} eq 'ARRAY' ) {
364                if ( ref $h2->{$k} eq 'ARRAY' ) {
365                    push @{ $h1->{$k} }, @{ $h2->{$k} };
366                }
367                else {
368                    push @{ $h1->{$k} }, $h2->{$k};
369                }
370            }
371            else {
372                $h1->{$k} = [ $h1->{$k}, $h2->{$k} ];
373            }
374        }
375        else {
376            $h1->{$k} = $h2->{$k};
377        }
378    }
379}
380
381# The above functions can all be used to make MT objects (and subobjects).
382# The difference between them is characterized by these assertions:
383#
384#  $mt = MT::App::Search->new();
385#  assert($mt->isa('MT::App::Search'))
386#
387#  $mt1 = MT->instance
388#  $mt2 = MT->instance
389#  assert($mt1 == $mt2);
390#
391#  $mt1 = MT::App::CMS->construct()
392#  $mt2 = MT::App::CMS->construct()
393#  assert($mt1 != $mt2);
394#
395# TBD: make a test script for these.
396
397sub unplug {
398}
399
400sub config {
401    my $mt = shift;
402    ref $mt or $mt = MT->instance;
403    unless ( $mt->{cfg} ) {
404        require MT::ConfigMgr;
405        weaken( $mt->{cfg} = MT::ConfigMgr->instance );
406    }
407    if (@_) {
408        my $setting = shift;
409        @_ ? $mt->{cfg}->set( $setting, @_ ) : $mt->{cfg}->get($setting);
410    }
411    else {
412        $mt->{cfg};
413    }
414}
415
416sub request {
417    my $pkg  = shift;
418    my $inst = ref($pkg) ? $pkg : $pkg->instance;
419    unless ( $inst->{request} ) {
420        require MT::Request;
421        $inst->{request} = MT::Request->instance;
422    }
423    if (@_) {
424        $inst->{request}->stash(@_);
425    }
426    else {
427        $inst->{request};
428    }
429}
430
431sub log {
432    my $mt = shift;
433    unless ($plugins_installed) {
434        # finish init_schema here since we have to log something
435        # to the database.
436        $mt->init_schema();
437    }
438    my $msg;
439    if ( !@_ ) {    # single parameter to log, so $mt must be message
440        $msg = $mt;
441        $mt  = MT->instance;
442    }
443    else {          # multiple parameters to log; second one is message
444        $msg = shift;
445    }
446    my $log_class = $mt->model('log');
447    my $log = $log_class->new();
448    if ( ref $msg eq 'HASH' ) {
449        $log->set_values($msg);
450    }
451    elsif ( ( ref $msg ) && ( UNIVERSAL::isa( $msg, 'MT::Log' ) ) ) {
452        $log = $msg;
453    }
454    else {
455        $log->message($msg);
456    }
457    $log->level( MT::Log::INFO() )
458      unless defined $log->level;
459    $log->class('system')
460      unless defined $log->class;
461    $log->save();
462    print STDERR MT->translate( "Message: [_1]", $log->message ) . "\n"
463      if $MT::DebugMode;
464}
465my $plugin_full_path;
466
467sub run_tasks {
468    my $mt = shift;
469    require MT::TaskMgr;
470    MT::TaskMgr->run_tasks(@_);
471}
472
473sub add_plugin {
474    my $class = shift;
475    my ($plugin) = @_;
476    if ( ref $plugin eq 'HASH' ) {
477        require MT::Plugin;
478        $plugin = new MT::Plugin($plugin);
479    }
480    $plugin->{name} ||= $plugin_sig;
481    $plugin->{plugin_sig} = $plugin_sig;
482
483    my $id = $plugin->id;
484    unless ($plugin_envelope) {
485        warn "MT->add_plugin improperly called outside of MT plugin load loop.";
486        return;
487    }
488    $plugin->envelope($plugin_envelope);
489    Carp::confess("You cannot register multiple plugin objects from a single script. $plugin_sig")
490      if exists( $Plugins{$plugin_sig} )
491      && ( exists $Plugins{$plugin_sig}{object} );
492
493    $Components{ lc $id } = $plugin if $id;
494    $Plugins{$plugin_sig}{object} = $plugin;
495    $plugin->{full_path}  = $plugin_full_path;
496    $plugin->path($plugin_full_path);
497    unless ( $plugin->{registry} && ( %{ $plugin->{registry} } ) ) {
498        $plugin->{registry} = $plugin_registry;
499    }
500    if ( $plugin->{registry} ) {
501        if ( my $settings = $plugin->{registry}{config_settings} ) {
502            $settings = $plugin->{registry}{config_settings} = $settings->()
503              if ref($settings) eq 'CODE';
504            $class->config->define($settings);
505        }
506    }
507    push @Components, $plugin;
508    1;
509}
510
511our %CallbackAlias;
512our $CallbacksEnabled = 1;
513my %CallbacksEnabled;
514my @Callbacks;
515
516sub add_callback {
517    my $class = shift;
518    my ( $meth, $priority, $plugin, $code ) = @_;
519    if ( $meth =~ m/^(.+::)?([^\.]+)(\..+)?$/ ) {
520
521        # Remap (whatever)::(name).(something)
522        if ( exists $CallbackAlias{$2} ) {
523            $meth = $CallbackAlias{$2};
524            $meth = $1 . $meth if $1;
525            $meth = $meth . $3 if $3;
526        }
527    }
528    $meth = $CallbackAlias{$meth} if exists $CallbackAlias{$meth};
529    my $internal = 0;
530    if ( ref $plugin ) {
531        if ( ( defined $mt_inst ) && ( $plugin == $mt_inst ) ) {
532            $plugin   = undef;
533            $internal = 1;
534        }
535        elsif ( !UNIVERSAL::isa( $plugin, "MT::Component" ) ) {
536            return $class->trans_error(
537"If present, 3rd argument to add_callback must be an object of type MT::Component or MT::Plugin"
538            );
539        }
540    }
541    if ( ( ref $code ) ne 'CODE' ) {
542        if ( ref $code ) {
543            return $class->trans_error(
544                '4th argument to add_callback must be a CODE reference.');
545        }
546        else {
547            # Defer until callback is used
548            # if ($plugin) {
549            #     $code = MT->handler_to_coderef($code);
550            # }
551        }
552    }
553
554    # 0 and 11 are exclusive.
555    if ( $priority == 0 || $priority == 11 ) {
556        if ( $Callbacks[$priority]->{$meth} ) {
557            return $class->trans_error("Two plugins are in conflict");
558        }
559    }
560    return $class->trans_error( "Invalid priority level [_1] at add_callback",
561        $priority )
562      if ( ( $priority < 0 ) || ( $priority > 11 ) );
563    require MT::Callback;
564    $CallbacksEnabled{$meth} = 1;
565    ## push @{$Plugins{$plugin_sig}{callbacks}}, "$meth Callback" if $plugin_sig;
566    my $cb = new MT::Callback(
567        plugin   => $plugin,
568        code     => $code,
569        priority => $priority,
570        internal => $internal,
571        method   => $meth
572    );
573    push @{ $Callbacks[$priority]->{$meth} }, $cb;
574    $cb;
575}
576
577sub remove_callback {
578    my $class    = shift;
579    my ($cb)     = @_;
580    my $priority = $cb->{priority};
581    my $method   = $cb->{method};
582    my $list     = $Callbacks[$priority];
583    return unless $list;
584    my $cbarr = $list->{$method};
585    return unless $cbarr;
586    @$cbarr = grep { $_ != $cb } @$cbarr;
587}
588
589# For use by MT internal code
590sub _register_core_callbacks {
591    my $class = shift;
592    my ($callback_table) = @_;
593    foreach my $name ( keys %$callback_table ) {
594        $class->add_callback( $name, 5, $mt_inst, $callback_table->{$name} )
595          || return;
596    }
597    1;
598}
599
600sub register_callbacks {
601    my $class = shift;
602    my ($callback_list) = @_;
603    foreach my $cb (@$callback_list) {
604        $class->add_callback( $cb->{name}, $cb->{priority}, $cb->{plugin},
605            $cb->{code} )
606          || return;
607    }
608    1;
609}
610
611our $CB_ERR;
612sub callback_error { $CB_ERR = $_[0]; }
613sub callback_errstr { $CB_ERR }
614
615sub run_callback {
616    my $class = shift;
617    my ( $cb, @args ) = @_;
618
619    $cb->error();    # reset the error string
620    my $result = eval {
621        # line __LINE__ __FILE__
622        $cb->invoke(@args);
623    };
624    if ( my $err = $@ ) {
625        $cb->error($err);
626        my $plugin = $cb->{plugin};
627        my $name;
628        if ( $cb->{internal} ) {
629            $name = "Internal callback";
630        }
631        elsif ( UNIVERSAL::isa( $plugin, 'MT::Plugin' ) ) {
632            $name = $plugin->name() || MT->translate("Unnamed plugin");
633        }
634        else {
635            $name = MT->translate("Unnamed plugin");
636        }
637        require MT::Log;
638        MT->log(
639            {
640                message => MT->translate( "[_1] died with: [_2]", $name, $err ),
641                class   => 'system',
642                category => 'callback',
643                level    => MT::Log::ERROR(),
644            }
645        );
646        return 0;
647    }
648    if ( $cb->errstr() ) {
649        return 0;
650    }
651    return $result;
652}
653
654# A callback should return a true/false value. The result of
655# run_callbacks is the logical AND of all the callback's return
656# values. Some hookpoints will ignore the return value: e.g. object
657# callbacks don't use it. By convention, those that use it have Filter
658# at the end of their names (CommentPostFilter, CommentThrottleFilter,
659# etc.)
660# Note: this composition is not short-circuiting. All callbacks are
661# executed even if one has already returned false.
662# ALSO NOTE: failure (dying or setting $cb->errstr) does not force a
663# "false" return.
664# THINK: are there cases where a true value should override all false values?
665# that is, where logical OR is the right way to compose multiple callbacks?
666sub run_callbacks {
667    my $class = shift;
668    my ( $meth, @args ) = @_;
669    return 1 unless $CallbacksEnabled && %CallbacksEnabled;
670    $meth = $CallbackAlias{$meth} if exists $CallbackAlias{$meth};
671    my @methods;
672
673    # execution:
674    #   Full::Name.<variant>
675    #   *::Name.<variant> OR Name.<variant>
676    #   Full::Name
677    #   *::Name OR Name
678    push @methods, $meth if $CallbacksEnabled{$meth};    # bleh::blah variant
679    if ( $meth =~ /::/ ) {    # presence of :: implies it's an obj. cb
680        my $name = $meth;
681        $name =~ s/^.*::([^:]*)$/$1/;
682        $name = $CallbackAlias{ '*::' . $name }
683          if exists $CallbackAlias{ '*::' . $name };
684        push @methods, '*::' . $name
685          if $CallbacksEnabled{ '*::' . $name };    # *::blah variant
686        push @methods, $name if $CallbacksEnabled{$name};    # blah variant
687    }
688    if ( $meth =~ /\./ ) {    # presence of ' ' implies it is a variant callback
689        my ($name) = split /\./, $meth, 2;
690        $name = $CallbackAlias{$name} if exists $CallbackAlias{$name};
691        push @methods, $name if $CallbacksEnabled{$name};    # bleh::blah
692        if ( $name =~ m/::/ ) {
693            my $name2 = $name;
694            $name2 =~ s/^.*::([^:]*)$/$1/;
695            $name2 = $CallbackAlias{ '*::' . $name2 }
696              if exists $CallbackAlias{ '*::' . $name2 };
697            push @methods, '*::' . $name2
698              if $CallbacksEnabled{ '*::' . $name2 };        # *::blah
699            push @methods, $name2 if $CallbacksEnabled{$name2};    # blah
700        }
701    }
702    return 1 unless @methods;
703
704    $CallbacksEnabled{$_} = 0 for @methods;
705    my @errors;
706    my $filter_value = 1;
707    my $first_error;
708
709    foreach my $callback_sheaf (@Callbacks) {
710        for my $meth (@methods) {
711            if ( my $set = $callback_sheaf->{$meth} ) {
712                for my $cb (@$set) {
713                    my $result = $class->run_callback( $cb, @args );
714                    $filter_value &&= $result;
715                    if ( !$result ) {
716                        if ( $cb->errstr() ) {
717                            push @errors, $cb->errstr();
718                        }
719                        if ( !defined($first_error) ) {
720                            $first_error = $cb->errstr();
721                        }
722                    }
723                }
724            }
725        }
726    }
727
728    callback_error( join( '', @errors ) );
729
730    $CallbacksEnabled{$_} = 1 for @methods;
731    if ( !$filter_value ) {
732        return $class->error($first_error);
733    }
734    else {
735        return $filter_value;
736    }
737}
738
739sub user_class {
740    shift->{user_class};
741}
742
743sub find_config {
744    my $mt = shift;
745    my ($param) = @_;
746
747    $param->{Config}    ||= $ENV{MT_CONFIG};
748    $param->{Directory} ||= $ENV{MT_HOME};
749    if ( !$param->{Directory} ) {
750        if ( $param->{Config} ) {
751            $param->{Directory} = dirname( $param->{Config} );
752        }
753        else {
754            $param->{Directory} = dirname($0) || $ENV{PWD} || '.';
755        }
756    }
757
758    # the directory is the more important parameter between it and
759    # the config parameter. if config is unreadable, then scan for
760    # a config file using the directory as a base.  we support
761    # either mt.cfg or mt-config.cgi for the config file name. the
762    # latter being a more secure choice since it is unreadable from
763    # a browser.
764    for my $cfg_file ( $param->{Config},
765        File::Spec->catfile( $param->{Directory}, 'mt-config.cgi' ),
766        'mt-config.cgi' )
767    {
768        return $cfg_file if $cfg_file && -r $cfg_file && -f $cfg_file;
769    }
770    return undef;
771}
772
773sub init_schema {
774    require MT::Object;
775    MT::Object->install_pre_init_properties();
776}
777
778sub init_permissions {
779    require MT::Permission;
780    MT::Permission->init_permissions;
781}
782
783sub init_config {
784    my $mt = shift;
785    my ($param) = @_;
786
787    my $cfg_file = $mt->find_config($param);
788    return $mt->error(
789"Missing configuration file. Maybe you forgot to move mt-config.cgi-original to mt-config.cgi?"
790    ) unless $cfg_file;
791    $cfg_file = File::Spec->rel2abs($cfg_file);
792
793    # translate the config file's location to an absolute path, so we
794    # can use that directory as a basis for calculating other relative
795    # paths found in the config file.
796    my $config_dir = $mt->{config_dir} = dirname($cfg_file);
797
798    # store the mt_dir (home) as an absolute path; fallback to the config
799    # directory if it isn't set.
800    $mt->{mt_dir} =
801      $param->{Directory}
802      ? File::Spec->rel2abs( $param->{Directory} )
803      : $mt->{config_dir};
804    $mt->{mt_dir} ||= dirname($0);
805
806    # also make note of the active application path; this is derived by
807    # checking the PWD environment variable, the dirname of $0,
808    # the directory of SCRIPT_FILENAME and lastly, falls back to mt_dir
809    $mt->{app_dir} = $ENV{PWD} || "";
810    $mt->{app_dir} = dirname($0)
811      if !$mt->{app_dir}
812      || !File::Spec->file_name_is_absolute( $mt->{app_dir} );
813    $mt->{app_dir} = dirname( $ENV{SCRIPT_FILENAME} )
814      if $ENV{SCRIPT_FILENAME}
815      && ( !$mt->{app_dir}
816        || ( !File::Spec->file_name_is_absolute( $mt->{app_dir} ) ) );
817    $mt->{app_dir} ||= $mt->{mt_dir};
818    $mt->{app_dir} = File::Spec->rel2abs( $mt->{app_dir} );
819
820    my $cfg = $mt->config;
821    $cfg->define( $mt->registry('config_settings') );
822    $cfg->read_config($cfg_file) or return $mt->error( $cfg->errstr );
823    $mt->{cfg_file} = $cfg_file;
824
825    my @mt_paths = $cfg->paths;
826    for my $meth (@mt_paths) {
827        my $path = $cfg->get( $meth, undef );
828        my $type = $cfg->type($meth);
829        if ( defined $path ) {
830            if ( $type eq 'ARRAY' ) {
831                my @paths = $cfg->get($meth);
832                local $_;
833                foreach (@paths) {
834                    next if File::Spec->file_name_is_absolute($_);
835                    $_ = File::Spec->catfile( $config_dir, $_ );
836                }
837                $cfg->$meth( \@paths );
838            }
839            else {
840                if ( !File::Spec->file_name_is_absolute($path) ) {
841                    $path = File::Spec->catfile( $config_dir, $path );
842                    $cfg->$meth($path);
843                }
844            }
845        }
846        else {
847            next if $type eq 'ARRAY';
848            my $path = $cfg->default($meth);
849            if ( defined $path ) {
850                $cfg->$meth( File::Spec->catfile( $config_dir, $path ) );
851            }
852        }
853    }
854
855    return $mt->trans_error("Bad ObjectDriver config")
856      unless $cfg->ObjectDriver;
857
858    if ( $MT::DebugMode = $cfg->DebugMode ) {
859        require Data::Dumper;
860        $Data::Dumper::Terse    = 1;
861        $Data::Dumper::Maxdepth = 4;
862        $Data::Dumper::Sortkeys = 1;
863        $Data::Dumper::Indent   = 1;
864    }
865
866    if ($cfg->PerformanceLogging && $cfg->ProcessMemoryCommand) {
867        $mt->log_times();
868    }
869
870    $mt->set_language( $cfg->DefaultLanguage );
871
872    my $cgi_path = $cfg->CGIPath;
873    if ( !$cgi_path || $cgi_path =~ m!http://www\.example\.com/! ) {
874        return $mt->trans_error("Bad CGIPath config");
875    }
876
877    $mt->{cfg} = $cfg;
878
879    1;
880}
881
882{
883my ($memory_start);
884sub log_times {
885    my $pkg = shift;
886
887    my $timer = $pkg->get_timer;
888    return unless $timer;
889
890    my $memory;
891    my $cmd = $pkg->config->ProcessMemoryCommand;
892    if ($cmd) {
893        my $re;
894        if (ref($cmd) eq 'HASH') {
895            $re = $cmd->{regex};
896            $cmd = $cmd->{command};
897        }
898        $cmd =~ s/\$\$/$$/g;
899        $memory = `$cmd`;
900        if ($re) {
901            if ($memory =~ m/$re/) {
902                $memory = $1;
903                $memory =~ s/\D//g;
904            }
905        } else {
906            $memory =~ s/\s+//gs;
907        }
908    }
909
910    # Called at the start of the process; so we're only recording
911    # the memory usage at the start of the app right now.
912    unless ($timer->{elapsed}) {
913        $memory_start = $memory;
914        return;
915    }
916
917    require File::Spec;
918    my $dir = MT->config('PerformanceLoggingPath') or return;
919
920    my @time = localtime(time);
921    my $file = sprintf("pl-%04d%02d%02d.log", $time[5] + 1900, $time[4]+1, $time[3]);
922    my $log_file = File::Spec->catfile( $dir, $file );
923
924    my $first_write = ! -f $log_file;
925
926    local *PERFLOG;
927    open PERFLOG, ">>$log_file";
928    require Fcntl;
929    flock(PERFLOG, Fcntl::LOCK_EX());
930
931    if ($first_write) {
932        require Config;
933        my ($osname, $osvers) = ($Config::Config{osname}, $Config::Config{osvers});
934        print PERFLOG "# Operating System: $osname/$osvers\n";
935        print PERFLOG "# Platform: $^O\n";
936        my $ver = ref($^V) eq 'version' ? $^V->normal : ( $^V ? join('.', unpack 'C*', $^V) : $] );
937        print PERFLOG "# Perl Version: $ver\n";
938        print PERFLOG "# Web Server: $ENV{SERVER_SOFTWARE}\n";
939        require MT::Object;
940        my $driver = MT::Object->driver;
941        if ($driver) {
942            my $dbh = $driver->r_handle;
943            if ($dbh) {
944                my $dbname = $dbh->get_info( 17 ); # SQL_DBMS_NAME
945                my $dbver = $dbh->get_info( 18 ); # SQL_DBMS_VER
946                if ($dbname && $dbver) {
947                    print PERFLOG "# Database: $dbname/$dbver\n";
948                }
949            }
950        }
951        my ($drname, $drh) = each %DBI::installed_drh;
952        print PERFLOG "# Database Library: DBI/" . $DBI::VERSION . "; DBD/" . $drh->{Version} . "\n";
953        if ($ENV{MOD_PERL}) {
954            print PERFLOG "# App Mode: mod_perl\n";
955        }
956        elsif ($ENV{FAST_CGI}) {
957            print PERFLOG "# App Mode: FastCGI\n";
958        }
959        else {
960            print PERFLOG "# App Mode: CGI\n";
961        }
962    }
963
964    if ($memory) {
965        print PERFLOG $timer->dump_line("mem_start=$memory_start", "mem_end=$memory");
966    } else {
967        print PERFLOG $timer->dump_line();
968    }
969
970    close PERFLOG;
971}
972}
973
974sub get_timer {
975    my $mt = shift;
976    $mt = MT->instance unless ref $mt;
977    my $timer = $mt->request('timer');
978    unless (defined $timer) {
979        if (MT->config('PerformanceLogging')) {
980            my $uri;
981            if ($mt->isa('MT::App')) {
982                $uri = $mt->uri( args => { $mt->param_hash } );
983            }
984            require MT::Util::ReqTimer;
985            $timer = MT::Util::ReqTimer->new( $uri );
986        } else {
987            $timer = 0;
988        }
989        $mt->request('timer', $timer);
990    }
991    return $timer;
992}
993
994sub time_this {
995    my $mt = shift;
996    my ($str, $code) = @_;
997    my $timer = $mt->get_timer();
998    my $ret;
999    if ($timer) {
1000        $timer->pause_partial();
1001        $ret = $code->();
1002        $timer->mark($str);
1003    } else {
1004        $ret = $code->();
1005    }
1006    return $ret;
1007}
1008
1009sub init_config_from_db {
1010    my $mt = shift;
1011    my ($param) = @_;
1012    my $cfg = $mt->config;
1013    $cfg->read_config_db();
1014
1015    # Tell any instantiated drivers to reconfigure themselves as necessary
1016    MT::ObjectDriverFactory->configure;
1017
1018    1;
1019}
1020
1021sub bootstrap {
1022    my $pkg = shift;
1023    $pkg->init_paths() or return;
1024    $pkg->init_core()  or return;
1025}
1026
1027sub init_paths {
1028    my $mt = shift;
1029    my ($param) = @_;
1030
1031    # determine MT directory
1032    my ($orig_dir);
1033    require File::Spec;
1034    if ( !( $MT_DIR = $ENV{MT_HOME} ) ) {
1035        if ( $0 =~ m!(.*([/\\]))! ) {
1036            $orig_dir = $MT_DIR = $1;
1037            my $slash = $2;
1038            $MT_DIR =~ s!(?:[/\\]|^)(?:plugins[/\\].*|tools[/\\])$!$slash!;
1039            $MT_DIR = '' if ( $MT_DIR =~ m!^\.?[\\/]$! );
1040        }
1041        else {
1042
1043            # MT_DIR/lib/MT.pm -> MT_DIR/lib -> MT_DIR
1044            $MT_DIR = dirname( dirname( File::Spec->rel2abs(__FILE__) ) );
1045        }
1046        unless ($MT_DIR) {
1047            $orig_dir = $MT_DIR = $ENV{PWD} || '.';
1048            $MT_DIR =~ s!(?:[/\\]|^)(?:plugins[/\\].*|tools[/\\]?)$!!;
1049        }
1050        $ENV{MT_HOME} = $MT_DIR;
1051    }
1052    unshift @INC, File::Spec->catdir( $MT_DIR,   'extlib' );
1053    unshift @INC, File::Spec->catdir( $orig_dir, 'lib' )
1054      if $orig_dir && ( $orig_dir ne $MT_DIR );
1055
1056    $mt->set_language('__BUILD_LANGUAGE__');
1057
1058    if ( my $cfg_file = $mt->find_config($param) ) {
1059        $cfg_file = File::Spec->rel2abs($cfg_file);
1060        $CFG_FILE = $cfg_file;
1061    }
1062    else {
1063        return $mt->trans_error(
1064"Missing configuration file. Maybe you forgot to move mt-config.cgi-original to mt-config.cgi?"
1065        ) if ref($mt);
1066    }
1067
1068    # store the mt_dir (home) as an absolute path; fallback to the config
1069    # directory if it isn't set.
1070    $MT_DIR ||=
1071      $param->{directory}
1072      ? File::Spec->rel2abs( $param->{directory} )
1073      : $CFG_DIR;
1074    $MT_DIR ||= dirname($0);
1075
1076    # also make note of the active application path; this is derived by
1077    # checking the PWD environment variable, the dirname of $0,
1078    # the directory of SCRIPT_FILENAME and lastly, falls back to mt_dir
1079    $APP_DIR = $ENV{PWD} || "";
1080    $APP_DIR = dirname($0)
1081      if !$APP_DIR || !File::Spec->file_name_is_absolute($APP_DIR);
1082    $APP_DIR = dirname( $ENV{SCRIPT_FILENAME} )
1083      if $ENV{SCRIPT_FILENAME}
1084      && ( !$APP_DIR || ( !File::Spec->file_name_is_absolute($APP_DIR) ) );
1085    $APP_DIR ||= $MT_DIR;
1086    $APP_DIR = File::Spec->rel2abs($APP_DIR);
1087
1088    return 1;
1089}
1090
1091sub init_core {
1092    my $mt = shift;
1093    return if exists $Components{'core'};
1094    require MT::Core;
1095    my $c = MT::Core->new( { id => 'core', path => $MT_DIR } )
1096      or die MT::Core->errstr;
1097    $Components{'core'} = $c;
1098
1099    # Additional locale-specific defaults
1100    my $defaults = $c->{registry}{config_settings};
1101    $defaults->{DefaultLanguage}{default} = '__BUILD_LANGUAGE__';
1102    $defaults->{NewsboxURL}{default} = '__NEWSBOX_URL__';
1103    $defaults->{LearningNewsURL}{default} = '__LEARNINGNEWS_URL__';
1104    $defaults->{SupportURL}{default} = '__SUPPORT_URL__';
1105    $defaults->{NewsURL}{default} = '__NEWS_URL__';
1106    #$defaults->{HelpURL}{default} = '__HELP_URL__';
1107    $defaults->{DefaultTimezone}{default} = '__DEFAULT_TIMEZONE__';
1108    $defaults->{TimeOffset}{default} = '__DEFAULT_TIMEZONE__';
1109    $defaults->{MailEncoding}{default} = '__MAIL_ENCODING__';
1110    $defaults->{ExportEncoding}{default} = '__EXPORT_ENCODING__';
1111    $defaults->{LogExportEncoding}{default} = '__LOG_EXPORT_ENCODING__';
1112    $defaults->{CategoryNameNodash}{default} = '__CATEGORY_NAME_NODASH__';
1113    $defaults->{PublishCharset}{default} = '__PUBLISH_CHARSET__';
1114
1115    push @Components, $c;
1116    return 1;
1117}
1118
1119sub init {
1120    my $mt    = shift;
1121    my %param = @_;
1122
1123    $mt->bootstrap() unless $MT_DIR;
1124    $mt->{mt_dir}     = $MT_DIR;
1125    $mt->{config_dir} = $CFG_DIR;
1126    $mt->{app_dir}    = $APP_DIR;
1127
1128    $mt->init_callbacks();
1129
1130    ## Initialize the language to the default in case any errors occur in
1131    ## the rest of the initialization process.
1132    $mt->init_config( \%param ) or return;
1133    $mt->init_addons(@_)       or return;
1134    $mt->init_config_from_db( \%param ) or return;
1135    $mt->init_plugins(@_)       or return;
1136    $plugins_installed = 1;
1137    $mt->init_schema();
1138    $mt->init_permissions();
1139
1140    # Load MT::Log so constants are available
1141    require MT::Log;
1142
1143    $mt->run_callbacks('post_init', $mt, \%param);
1144    return $mt;
1145}
1146
1147sub init_callbacks {
1148    my $mt = shift;
1149    MT->_register_core_callbacks({
1150        'build_file_filter' => sub { MT->publisher->queue_build_file_filter(@_) },
1151        'cms_upload_file' => \&core_upload_file_to_sync,
1152        'api_upload_file' => \&core_upload_file_to_sync,
1153    });
1154}
1155
1156sub core_upload_file_to_sync {
1157    my ($cb, %args) = @_;
1158    MT->upload_file_to_sync(%args);
1159}
1160
1161sub upload_file_to_sync {
1162    my $class = shift;
1163    my (%args) = @_;
1164
1165    # no need to do this unless we're syncing stuff.
1166    return unless MT->config('SyncTarget');
1167
1168    my $url = $args{url};
1169    my $file = $args{file};
1170    return unless -f $file;
1171
1172    my $blog = $args{blog};
1173    my $blog_id = $blog->id;
1174    return unless $blog->publish_queue;
1175
1176    require MT::FileInfo;
1177    my $base_url = $url;
1178    $base_url =~ s!^https?://[^/]+!!;
1179    my $fi = MT::FileInfo->load({ blog_id => $blog_id, url => $base_url });
1180    if (!$fi) {
1181        $fi = new MT::FileInfo;
1182        $fi->blog_id($blog_id);
1183        $fi->url($base_url);
1184        $fi->file_path($file);
1185    } else {
1186        $fi->file_path($file);
1187    }
1188    $fi->save;
1189
1190    require MT::TheSchwartz;
1191    require TheSchwartz::Job;
1192    my $job = TheSchwartz::Job->new();
1193    $job->funcname('MT::Worker::Sync');
1194    $job->uniqkey( $fi->id );
1195    $job->coalesce( ( $fi->blog_id || 0 ) . ':' . $$ . ':' . ( time - ( time % 10 ) ) );
1196    MT::TheSchwartz->insert($job);
1197}
1198
1199sub init_addons {
1200    my $mt = shift;
1201    my $cfg = $mt->config;
1202    my @PluginPaths;
1203
1204    unshift @PluginPaths, File::Spec->catdir( $MT_DIR, 'addons' );
1205    return $mt->_init_plugins_core({}, 1, \@PluginPaths);
1206}
1207
1208sub init_plugins {
1209    my $mt = shift;
1210
1211    # Load compatibility module for prior version
1212    # This should always be MT::Compat::v(MAJOR_RELEASE_VERSION - 1).
1213    require MT::Compat::v3;
1214
1215    require MT::Plugin;
1216    my $cfg          = $mt->config;
1217    my $use_plugins  = $cfg->UsePlugins;
1218    my @PluginPaths  = $cfg->PluginPath;
1219    my $PluginSwitch = $cfg->PluginSwitch || {};
1220    return $mt->_init_plugins_core($PluginSwitch, $use_plugins, \@PluginPaths);
1221}
1222
1223sub _init_plugins_core {
1224    my $mt = shift;
1225    my ($PluginSwitch, $use_plugins, $PluginPaths) = @_;
1226
1227    my $timer;
1228    if ($mt->config->PerformanceLogging) {
1229        $timer = $mt->get_timer();
1230    }
1231
1232    foreach my $PluginPath (@$PluginPaths) {
1233        my $plugin_lastdir = $PluginPath;
1234        $plugin_lastdir =~ s![\\/]$!!;
1235        $plugin_lastdir =~ s!.*[\\/]!!;
1236        local *DH;
1237        if ( opendir DH, $PluginPath ) {
1238            my @p = readdir DH;
1239          PLUGIN:
1240            for my $plugin (@p) {
1241                next if ( $plugin =~ /^\.\.?$/ || $plugin =~ /~$/ );
1242
1243                my $load_plugin = sub {
1244                    my ( $plugin, $sig ) = @_;
1245                    die "Bad plugin filename '$plugin'"
1246                      if ( $plugin !~ /^([-\\\/\@\:\w\.\s~]+)$/ );
1247                    local $plugin_sig      = $sig;
1248                    local $plugin_registry = {};
1249                    $plugin = $1;
1250                    if (
1251                        !$use_plugins
1252                        || ( exists $PluginSwitch->{$plugin_sig}
1253                            && !$PluginSwitch->{$plugin_sig} )
1254                      )
1255                    {
1256                        $Plugins{$plugin_sig}{full_path} = $plugin_full_path;
1257                        $Plugins{$plugin_sig}{enabled}   = 0;
1258                        return 0;
1259                    }
1260                    return 0 if exists $Plugins{$plugin_sig};
1261                    $Plugins{$plugin_sig}{full_path} = $plugin_full_path;
1262                    $timer->pause_partial if $timer;
1263                    eval "# line " . __LINE__ . " " . __FILE__ . "\nrequire '$plugin';";
1264                    $timer->mark("Loaded plugin " . $sig) if $timer;
1265                    if ($@) {
1266                        $Plugins{$plugin_sig}{error} = $@;
1267                        # Issue MT log within another eval block in the
1268                        # event that the plugin error is happening before
1269                        # the database has been initialized...
1270                        eval {
1271                            # line __LINE__ __FILE__
1272                            require MT::Log;
1273                            $mt->log(
1274                                {
1275                                    message => $mt->translate(
1276                                        "Plugin error: [_1] [_2]", $plugin,
1277                                        $Plugins{$plugin_sig}{error}
1278                                    ),
1279                                    class => 'system',
1280                                    level => MT::Log::ERROR()
1281                                }
1282                            );
1283                        };
1284                        return 0;
1285                    }
1286                    else {
1287                        if ( my $obj = $Plugins{$plugin_sig}{object} ) {
1288                            $obj->init_callbacks();
1289                        }
1290                        else {
1291
1292                            # A plugin did not register itself, so
1293                            # create a dummy plugin object which will
1294                            # cause it to show up in the plugin listing
1295                            # by it's filename.
1296                            MT->add_plugin( {} );
1297                        }
1298                    }
1299                    $Plugins{$plugin_sig}{enabled} = 1;
1300                    return 1;
1301                };
1302                $plugin_full_path = File::Spec->catfile( $PluginPath, $plugin );
1303                if ( -f $plugin_full_path ) {
1304                    $plugin_envelope = $plugin_lastdir;
1305                    $load_plugin->( $plugin_full_path, $plugin )
1306                      if $plugin_full_path =~ /\.pl$/;
1307                }
1308                else {
1309                    my $plugin_dir = $plugin;
1310                    $plugin_envelope = "$plugin_lastdir/" . $plugin;
1311
1312                    # handle config.yaml
1313                    my $yaml =
1314                      File::Spec->catdir( $plugin_full_path, 'config.yaml' );
1315
1316                    foreach my $lib (qw(lib extlib)) {
1317                        my $plib = File::Spec->catdir( $plugin_full_path, $lib );
1318                        unshift @INC, $plib if -d $plib;
1319                    }
1320
1321                    if ( -f $yaml ) {
1322                        my $pclass =
1323                          $plugin_dir =~ m/\.pack$/
1324                          ? 'MT::Component'
1325                          : 'MT::Plugin';
1326
1327                        # Don't process disabled plugin config.yaml files.
1328                        if (
1329                            $pclass eq 'MT::Plugin'
1330                            && (
1331                                !$use_plugins
1332                                || ( exists $PluginSwitch->{$plugin_dir}
1333                                    && !$PluginSwitch->{$plugin_dir} )
1334                            )
1335                          )
1336                        {
1337                            $Plugins{$plugin_dir}{full_path} =
1338                              $plugin_full_path;
1339                            $Plugins{$plugin_dir}{enabled} = 0;
1340                            next;
1341                        }
1342                        my $id = lc $plugin_dir;
1343                        $id =~ s/\.\w+$//;
1344                        my $p = $pclass->new(
1345                            {
1346                                id       => $id,
1347                                path     => $plugin_full_path,
1348                                envelope => $plugin_envelope
1349                            }
1350                        );
1351
1352                        # rebless? based on config?
1353                        local $plugin_sig = $plugin_dir;
1354                        MT->add_plugin($p);
1355                        $p->init_callbacks()
1356                            if $pclass eq 'MT::Plugin';
1357                        next;
1358                    }
1359
1360                    opendir SUBDIR, $plugin_full_path;
1361                    my @plugins = readdir SUBDIR;
1362                    closedir SUBDIR;
1363                    for my $plugin (@plugins) {
1364                        next if $plugin !~ /\.pl$/;
1365                        my $plugin_file =
1366                          File::Spec->catfile( $plugin_full_path, $plugin );
1367                        if ( -f $plugin_file ) {
1368                            $load_plugin->(
1369                                $plugin_file, $plugin_dir . '/' . $plugin
1370                            );
1371                        }
1372                    }
1373                }
1374            }
1375            closedir DH;
1376        }
1377    }
1378
1379    # Reset the Text_filters hash in case it was preloaded by plugins by
1380    # calling all_text_filters (Markdown in particular does this).
1381    # Upon calling all_text_filters again, it will be properly loaded by
1382    # querying the registry.
1383    %Text_filters = ();
1384
1385    1;
1386}
1387
1388my %addons;
1389
1390sub find_addons {
1391    my $mt = shift;
1392    my ($type) = @_;
1393
1394    unless (%addons) {
1395        my $addon_path = File::Spec->catdir( $MT_DIR, 'addons' );
1396        local *DH;
1397        if ( opendir DH, $addon_path ) {
1398            my @p = readdir DH;
1399            foreach my $p (@p) {
1400                next if $p eq '.' || $p eq '..';
1401                my $full_path = File::Spec->catdir( $addon_path, $p );
1402                if ( -d $full_path ) {
1403                    if ( $p =~ m/^(.+)\.(\w+)$/ ) {
1404                        my $label = $1;
1405                        my $id    = lc $1;
1406                        my $type  = $2;
1407                        if ( $type eq 'pack' ) {
1408                            $label .= ' Pack';
1409                        }
1410                        elsif ( $type eq 'theme' ) {
1411                            $label .= ' Theme';
1412                        }
1413                        elsif ( $type eq 'plugin' ) {
1414                            $label .= ' Plugin';
1415                        }
1416                        push @{ $addons{$type} },
1417                          {
1418                            label    => $label,
1419                            id       => $id,
1420                            envelope => 'addons/' . $p . '/',
1421                            path     => $full_path,
1422                          };
1423                    }
1424                }
1425            }
1426        }
1427    }
1428    if ($type) {
1429        my $addons = $addons{$type} ||= [];
1430        return $addons;
1431    }
1432    return 1;
1433}
1434
1435*mt_dir = \&server_path;
1436sub server_path { $_[0]->{mt_dir} }
1437sub app_dir     { $_[0]->{app_dir} }
1438sub config_dir  { $_[0]->{config_dir} }
1439
1440sub component {
1441    my $mt = shift;
1442    my ($id) = @_;
1443    return $Components{ lc $id };
1444}
1445
1446sub publisher {
1447    my $mt = shift;
1448    $mt = $mt->instance unless ref $mt;
1449    unless ( $mt->{WeblogPublisher} ) {
1450        require MT::WeblogPublisher;
1451        $mt->{WeblogPublisher} = new MT::WeblogPublisher();
1452    }
1453    $mt->{WeblogPublisher};
1454}
1455
1456sub rebuild {
1457    my $mt = shift;
1458    $mt->publisher->rebuild(@_)
1459      or return $mt->error( $mt->publisher->errstr );
1460}
1461
1462sub rebuild_entry {
1463    my $mt = shift;
1464    $mt->publisher->rebuild_entry(@_)
1465      or return $mt->error( $mt->publisher->errstr );
1466}
1467
1468sub rebuild_indexes {
1469    my $mt = shift;
1470    $mt->publisher->rebuild_indexes(@_)
1471      or return $mt->error( $mt->publisher->errstr );
1472}
1473
1474sub rebuild_archives {
1475    my $mt = shift;
1476    $mt->publisher->rebuild_archives(@_)
1477      or return $mt->error( $mt->publisher->errstr );
1478}
1479
1480sub ping {
1481    my $mt    = shift;
1482    my %param = @_;
1483    my $blog;
1484    require MT::Entry;
1485    require MT::Util;
1486    unless ( $blog = $param{Blog} ) {
1487        my $blog_id = $param{BlogID};
1488        $blog = MT::Blog->load($blog_id)
1489          or return $mt->trans_error( "Load of blog '[_1]' failed: [_2]",
1490            $blog_id, MT::Blog->errstr );
1491    }
1492
1493    my (@res);
1494
1495    my $send_updates = 1;
1496    if ( exists $param{OldStatus} ) {
1497        ## If this is a new entry (!$old_status) OR the status was previously
1498        ## set to draft, and is now set to publish, send the update pings.
1499        my $old_status = $param{OldStatus};
1500        if ( $old_status && $old_status eq MT::Entry::RELEASE() ) {
1501            $send_updates = 0;
1502        }
1503    }
1504
1505    if ( $send_updates && !( MT->config->DisableNotificationPings ) ) {
1506        ## Send update pings.
1507        my @updates = $mt->update_ping_list($blog);
1508        for my $url (@updates) {
1509            require MT::XMLRPC;
1510            if ( MT::XMLRPC->ping_update( 'weblogUpdates.ping', $blog, $url ) )
1511            {
1512                push @res, { good => 1, url => $url, type => "update" };
1513            }
1514            else {
1515                push @res,
1516                  {
1517                    good  => 0,
1518                    url   => $url,
1519                    type  => "update",
1520                    error => MT::XMLRPC->errstr
1521                  };
1522            }
1523        }
1524        if ( $blog->mt_update_key ) {
1525            require MT::XMLRPC;
1526            if ( MT::XMLRPC->mt_ping($blog) ) {
1527                push @res,
1528                  {
1529                    good => 1,
1530                    url  => $mt->{cfg}->MTPingURL,
1531                    type => "update"
1532                  };
1533            }
1534            else {
1535                push @res,
1536                  {
1537                    good  => 0,
1538                    url   => $mt->{cfg}->MTPingURL,
1539                    type  => "update",
1540                    error => MT::XMLRPC->errstr
1541                  };
1542            }
1543        }
1544    }
1545
1546    my $cfg     = $mt->{cfg};
1547    my $send_tb = $cfg->OutboundTrackbackLimit;
1548    return \@res if $send_tb eq 'off';
1549
1550    my @tb_domains;
1551    if ( $send_tb eq 'selected' ) {
1552        @tb_domains = $cfg->OutboundTrackbackDomains;
1553    }
1554    elsif ( $send_tb eq 'local' ) {
1555        my $iter = MT::Blog->load_iter();
1556        while ( my $b = $iter->() ) {
1557            next if $b->id == $blog->id;
1558            push @tb_domains, MT::Util::extract_domains( $b->site_url );
1559        }
1560    }
1561    my $tb_domains;
1562    if (@tb_domains) {
1563        $tb_domains = '';
1564        my %seen;
1565        local $_;
1566        foreach (@tb_domains) {
1567            next unless $_;
1568            $_ = lc($_);
1569            next if $seen{$_};
1570            $tb_domains .= '|' if $tb_domains ne '';
1571            $tb_domains .= quotemeta($_);
1572            $seen{$_} = 1;
1573        }
1574        $tb_domains = '(' . $tb_domains . ')' if $tb_domains;
1575    }
1576
1577    ## Send TrackBack pings.
1578    if ( my $entry = $param{Entry} ) {
1579        my $pings = $entry->to_ping_url_list;
1580
1581        my %pinged = map { $_ => 1 } @{ $entry->pinged_url_list };
1582        my $cats = $entry->categories;
1583        for my $cat (@$cats) {
1584            push @$pings, grep !$pinged{$_}, @{ $cat->ping_url_list };
1585        }
1586
1587        my $ua = MT->new_ua;
1588
1589        ## Build query string to be sent on each ping.
1590        my @qs;
1591        push @qs, 'title=' . MT::Util::encode_url( $entry->title );
1592        push @qs, 'url=' . MT::Util::encode_url( $entry->permalink );
1593        push @qs, 'excerpt=' . MT::Util::encode_url( $entry->get_excerpt );
1594        push @qs, 'blog_name=' . MT::Util::encode_url( $blog->name );
1595        my $qs = join '&', @qs;
1596
1597        ## Character encoding--best guess.
1598        my $enc = $mt->{cfg}->PublishCharset;
1599
1600        for my $url (@$pings) {
1601            $url =~ s/^\s*//;
1602            $url =~ s/\s*$//;
1603            my $url_domain;
1604            ($url_domain) = MT::Util::extract_domains($url);
1605            next if $tb_domains && lc($url_domain) !~ m/$tb_domains$/;
1606
1607            my $req = HTTP::Request->new( POST => $url );
1608            $req->content_type(
1609                "application/x-www-form-urlencoded; charset=$enc");
1610            $req->content($qs);
1611            my $res = $ua->request($req);
1612            if ( substr( $res->code, 0, 1 ) eq '2' ) {
1613                my $c = $res->content;
1614                my ( $error, $msg ) =
1615                  $c =~ m!<error>(\d+).*<message>(.+?)</message>!s;
1616                if ($error) {
1617                    push @res,
1618                      {
1619                        good  => 0,
1620                        url   => $url,
1621                        type  => 'trackback',
1622                        error => $msg
1623                      };
1624                }
1625                else {
1626                    push @res, { good => 1, url => $url, type => 'trackback' };
1627                }
1628            }
1629            else {
1630                push @res,
1631                  {
1632                    good  => 0,
1633                    url   => $url,
1634                    type  => 'trackback',
1635                    error => "HTTP error: " . $res->status_line
1636                  };
1637            }
1638        }
1639    }
1640    \@res;
1641}
1642
1643sub ping_and_save {
1644    my $mt    = shift;
1645    my %param = @_;
1646    if ( my $entry = $param{Entry} ) {
1647        my $results = MT::ping( $mt, @_ ) or return;
1648        my %still_ping;
1649        my $pinged = $entry->pinged_url_list;
1650        for my $res (@$results) {
1651            next if $res->{type} ne 'trackback';
1652            if ( !$res->{good} ) {
1653                $still_ping{ $res->{url} } = 1;
1654            }
1655            push @$pinged,
1656              $res->{url}
1657              . ( $res->{good}
1658                ? ''
1659                : ' ' . MT::I18N::encode_text( $res->{error} ) );
1660        }
1661        $entry->pinged_urls( join "\n", @$pinged );
1662        $entry->to_ping_urls( join "\n", keys %still_ping );
1663        $entry->save or return $mt->error( $entry->errstr );
1664        return $results;
1665    }
1666    1;
1667}
1668
1669sub needs_ping {
1670    my $mt    = shift;
1671    my %param = @_;
1672    my $blog  = $param{Blog};
1673    my $entry = $param{Entry};
1674    require MT::Entry;
1675    return unless $entry->status == MT::Entry::RELEASE();
1676    my $old_status = $param{OldStatus};
1677    my %list;
1678    ## If this is a new entry (!$old_status) OR the status was previously
1679    ## set to draft, and is now set to publish, send the update pings.
1680    if ( ( !$old_status || $old_status ne MT::Entry::RELEASE() )
1681        && !( MT->config->DisableNotificationPings ) )
1682    {
1683        my @updates = $mt->update_ping_list($blog);
1684        @list{@updates} = (1) x @updates;
1685        $list{ $mt->{cfg}->MTPingURL } = 1 if $blog && $blog->mt_update_key;
1686    }
1687    if ($entry) {
1688        @list{ @{ $entry->to_ping_url_list } } = ();
1689        my %pinged = map { $_ => 1 } @{ $entry->pinged_url_list };
1690        my $cats = $entry->categories;
1691        for my $cat (@$cats) {
1692            @list{ grep !$pinged{$_}, @{ $cat->ping_url_list } } = ();
1693        }
1694    }
1695    my @list = keys %list;
1696    return unless @list;
1697    \@list;
1698}
1699
1700sub update_ping_list {
1701    my $mt = shift;
1702    my ($blog) = @_;
1703
1704    my @updates;
1705    if ( my $pings = MT->registry('ping_servers') ) {
1706        my $up = $blog->update_pings;
1707        if ($up) {
1708            foreach ( split ',', $up ) {
1709                next unless exists $pings->{$_};
1710                push @updates, $pings->{$_}->{url};
1711            }
1712        }
1713    }
1714    if ( my $others = $blog->ping_others ) {
1715        push @updates, split /\r?\n/, $others;
1716    }
1717    my %updates;
1718    for my $url (@updates) {
1719        for ($url) {
1720            s/^\s*//;
1721            s/\s*$//;
1722        }
1723        next unless $url =~ /\S/;
1724        $updates{$url}++;
1725    }
1726    keys %updates;
1727}
1728
1729{
1730    my $LH;
1731
1732    sub set_language {
1733        my $pkg = shift;
1734        require MT::L10N;
1735        $LH = MT::L10N->get_handle(@_);
1736
1737        # Clear any l10n_handles in request
1738        $pkg->request( 'l10n_handle', {} );
1739        return $LH;
1740    }
1741
1742    require MT::I18N;
1743
1744    sub translate {
1745        my $this = shift;
1746        my $app = ref($this) ? $this : $this->app;
1747        if ( $app->{component} ) {
1748            if ( my $c = $app->component( $app->{component} ) ) {
1749                local $app->{component} = undef;
1750                return $c->translate(@_);
1751            }
1752        }
1753        my ( $format, @args ) = @_;
1754        foreach (@args) {
1755            $_ = $_->() if ref($_) eq 'CODE';
1756        }
1757        my $enc = MT->instance->config('PublishCharset') || 'utf-8';
1758        return $LH->maketext( $format, @args ) if $enc =~ m/utf-?8/i;
1759        $format = MT::I18N::encode_text( $format, $enc, 'utf-8' );
1760        MT::I18N::encode_text(
1761            $LH->maketext(
1762                $format,
1763                map { MT::I18N::encode_text( $_, $enc, 'utf-8' ) } @args
1764            ),
1765            'utf-8', $enc
1766        );
1767    }
1768
1769    sub translate_templatized {
1770        my $mt = shift;
1771        my $app = ref($mt) ? $mt : $mt->app;
1772        if ( $app->{component} ) {
1773            if ( my $c = $app->component( $app->{component} ) ) {
1774                local $app->{component} = undef;
1775                return $c->translate_templatized(@_);
1776            }
1777        }
1778        my @cstack;
1779        my ($text) = @_;
1780        while (1) {
1781            $text =~ s!(<(/)?(?:_|MT)_TRANS(_SECTION)?(?:(?:\s+((?:\w+)\s*=\s*(["'])(?:(<(?:[^"'>]|"[^"]*"|'[^']*')+)?>|[^\5]+?)*?\5))+?\s*/?)?>)!
1782            my($msg, $close, $section, %args) = ($1, $2, $3);
1783            while ($msg =~ /\b(\w+)\s*=\s*(["'])((?:<(?:[^"'>]|"[^"]*"|'[^']*')+?>|[^\2])*?)?\2/g) {  #"
1784                $args{$1} = $3;
1785            }
1786            if ($section) {
1787                if ($close) {
1788                    $mt = pop @cstack;
1789                } else {
1790                    if ($args{component}) {
1791                        push @cstack, $mt;
1792                        $mt = MT->component($args{component})
1793                            or die "Bad translation component: $args{component}";
1794                    }
1795                    else {
1796                        die "__trans_section without a component argument";
1797                    }
1798                }
1799                '';
1800            }
1801            else {
1802                $args{params} = '' unless defined $args{params};
1803                my @p = map MT::Util::decode_html($_),
1804                        split /\s*%%\s*/, $args{params}, -1;
1805                @p = ('') unless @p;
1806                my $translation = $mt->translate($args{phrase}, @p);
1807                if (exists $args{escape}) {
1808                    if (lc($args{escape}) eq 'html') {
1809                        $translation = MT::Util::encode_html($translation);
1810                    } elsif (lc($args{escape}) eq 'url') {
1811                        $translation = MT::Util::encode_url($translation);
1812                    } else {
1813                        # fallback for js/javascript/singlequotes
1814                        $translation = MT::Util::encode_js($translation);
1815                    }
1816                }
1817                $translation;
1818            }
1819            !igem or last;
1820        }
1821        return $text;
1822    }
1823
1824    sub current_language { $LH->language_tag }
1825    sub language_handle  { $LH }
1826
1827    sub charset {
1828        my $mt = shift;
1829        $mt->{charset} = shift if @_;
1830        return $mt->{charset} if $mt->{charset};
1831        $mt->{charset} = $mt->config->PublishCharset
1832          || $mt->language_handle->encoding;
1833    }
1834}
1835
1836sub supported_languages {
1837    my $mt = shift;
1838    require MT::L10N;
1839    require File::Basename;
1840    ## Determine full path to lib/MT/L10N directory...
1841    my $lib =
1842      File::Spec->catdir( File::Basename::dirname( $INC{'MT/L10N.pm'} ),
1843        'L10N' );
1844    ## ... From that, determine full path to extlib/MT/L10N.
1845    ## To do that, we look for the last instance of the string 'lib'
1846    ## in $lib and replace it with 'extlib'. reverse is a nice tricky
1847    ## way of doing that.
1848    ( my $extlib = reverse $lib ) =~ s!bil!biltxe!;
1849    $extlib = reverse $extlib;
1850    my @dirs = ( $lib, $extlib );
1851    my %langs;
1852    for my $dir (@dirs) {
1853        opendir DH, $dir or next;
1854        for my $f ( readdir DH ) {
1855            my ($tag) = $f =~ /^(\w+)\.pm$/;
1856            next unless $tag;
1857            my $lh = MT::L10N->get_handle($tag);
1858            $langs{ $lh->language_tag } = $lh->language_name;
1859        }
1860        closedir DH;
1861    }
1862    \%langs;
1863}
1864
1865# For your convenience
1866sub trans_error {
1867    my $app = shift;
1868    $app->error( $app->translate(@_) );
1869}
1870
1871sub all_text_filters {
1872    unless (%Text_filters) {
1873        if ( my $filters = MT->registry('text_filters') ) {
1874            %Text_filters = %$filters if ref($filters) eq 'HASH';
1875        }
1876    }
1877    if (my $enabled_filters = MT->config('AllowedTextFilters')) {
1878        my %enabled = map { $_ => 1 } split /\s*,\s*/, $enabled_filters;
1879        %Text_filters = map { $_ => $Text_filters{$_} }
1880                        grep { exists $enabled{$_} }
1881                        keys %Text_filters;
1882    }
1883    return \%Text_filters;
1884}
1885
1886sub apply_text_filters {
1887    my $mt = shift;
1888    my ( $str, $filters, @extra ) = @_;
1889    my $all_filters = $mt->all_text_filters;
1890    for my $filter (@$filters) {
1891        my $f = $all_filters->{$filter} or next;
1892        my $code = $f->{code} || $f->{handler};
1893        unless ( ref($code) eq 'CODE' ) {
1894            $code = $mt->handler_to_coderef($code);
1895            $f->{code} = $code;
1896        }
1897        if ( !$code ) {
1898            warn "Bad text filter: $filter";
1899            next;
1900        }
1901        $str = $code->( $str, @extra );
1902    }
1903    return $str;
1904}
1905
1906sub static_path {
1907    my $app = shift;
1908    my $spath = $app->config->StaticWebPath;
1909    if (!$spath) {
1910        $spath = $app->config->CGIPath;
1911        $spath .= '/' unless $spath =~ m!/$!;
1912        $spath .= 'mt-static/';
1913    } else {
1914        $spath .= '/' unless $spath =~ m!/$!;
1915    }
1916    $spath;
1917}
1918
1919sub static_file_path {
1920    my $app = shift;
1921    return $app->{__static_file_path}
1922        if exists $app->{__static_file_path};
1923
1924    my $path = $app->config('StaticFilePath');
1925    return $app->{__static_file_path} = $path if defined $path;
1926
1927    # Attempt to derive StaticFilePath based on environment
1928    my $web_path = $app->config->StaticWebPath || 'mt-static';
1929    $web_path =~ s!^https?://[^/]+/!!;
1930    if ($app->can('document_root')) {
1931        my $doc_static_path = File::Spec->catdir($app->document_root(), $web_path);
1932        return $app->{__static_file_path} = $doc_static_path
1933            if -d $doc_static_path;
1934    }
1935    my $mtdir_static_path = File::Spec->catdir($app->mt_dir, 'mt-static');
1936    return $app->{__static_file_path} = $mtdir_static_path
1937        if -d $mtdir_static_path;
1938    return;
1939}
1940
1941sub template_paths {
1942    my $mt = shift;
1943    my @paths;
1944    my $path = $mt->config->TemplatePath;
1945    if ($mt->{plugin_template_path}) {
1946        if (File::Spec->file_name_is_absolute($mt->{plugin_template_path})) {
1947            push @paths, $mt->{plugin_template_path}
1948                if -d $mt->{plugin_template_path};
1949        } else {
1950            my $dir = File::Spec->catdir($mt->app_dir,
1951                                         $mt->{plugin_template_path});
1952            if (-d $dir) {
1953                push @paths, $dir;
1954            } else {
1955                $dir = File::Spec->catdir($mt->mt_dir,
1956                                          $mt->{plugin_template_path});
1957                push @paths, $dir if -d $dir;
1958            }
1959        }
1960    }
1961    if (my $alt_path = $mt->config->AltTemplatePath) {
1962        if (-d $alt_path) {    # AltTemplatePath is absolute
1963            push @paths, File::Spec->catdir($alt_path,
1964                                            $mt->{template_dir})
1965                if $mt->{template_dir};
1966            push @paths, $alt_path;
1967        }
1968    }
1969 
1970    for my $addon ( @{ $mt->find_addons('pack') } ) {
1971        push @paths, File::Spec->catdir($addon->{path}, 'tmpl', $mt->{template_dir})
1972            if $mt->{template_dir};
1973        push @paths, File::Spec->catdir($addon->{path}, 'tmpl');
1974    }
1975
1976    push @paths, File::Spec->catdir($path, $mt->{template_dir})
1977        if $mt->{template_dir};
1978    push @paths, $path;
1979 
1980    return @paths;
1981}
1982
1983sub find_file {
1984    my $mt = shift;
1985    my ($paths, $file) = @_;
1986    my $filename;
1987    foreach my $p (@$paths) {
1988        my $filepath = File::Spec->canonpath(File::Spec->catfile($p, $file));
1989        $filename = File::Spec->canonpath($filepath);
1990        return $filename if -f $filename;
1991    }
1992    undef;
1993}
1994
1995sub load_tmpl {
1996    my $mt = shift;
1997    if ( exists($mt->{component}) && ( $mt->{component} ne 'Core' ) ) {
1998        if (my $c = $mt->component($mt->{component})) {
1999            return $c->load_tmpl(@_);
2000        }
2001    }
2002
2003    my($file, @p) = @_;
2004    my $param;
2005    if (@p && (ref($p[$#p]) eq 'HASH')) {
2006        $param = pop @p;
2007    }
2008    my $cfg = $mt->config;
2009    require MT::Template;
2010    my $tmpl;
2011    my @paths = $mt->template_paths;
2012
2013    my $type = {'SCALAR' => 'scalarref', 'ARRAY' => 'arrayref'}->{ref $file}
2014        || 'filename';
2015    $tmpl = MT::Template->new(
2016        type => $type, source => $file,
2017        path => \@paths,
2018        filter => sub {
2019            my ($str, $fname) = @_;
2020            if ($fname) {
2021                $fname = File::Basename::basename($fname);
2022                $fname =~ s/\.tmpl$//;
2023                $mt->run_callbacks("template_source.$fname", $mt, @_);
2024            } else {
2025                $mt->run_callbacks("template_source", $mt, @_);
2026            }
2027            return $str;
2028        },
2029        @p);
2030    return $mt->error(
2031        $mt->translate("Loading template '[_1]' failed.", $file)) unless $tmpl;
2032    $mt->set_default_tmpl_params($tmpl);
2033    $tmpl->param($param) if $param;
2034    $tmpl;
2035}
2036
2037sub set_default_tmpl_params {
2038    my $mt = shift;
2039    my ($tmpl) = @_;
2040    my $param = {};
2041    $param->{mt_debug} = $MT::DebugMode;
2042    $param->{mt_beta} = 1 if MT->version_id =~ m/^\d+\.\d+(?:a|b|rc)/;
2043    $param->{static_uri} = $mt->static_path;
2044    $param->{mt_version} = MT->version_number;
2045    $param->{mt_version_id} = MT->version_id;
2046    $param->{mt_product_code} = MT->product_code;
2047    $param->{mt_product_name} = $mt->translate(MT->product_name);
2048    $param->{language_tag} = substr($mt->current_language, 0, 2);
2049    $param->{language_encoding} = $mt->charset;
2050    if ($mt->isa('MT::App')) {
2051        if (my $author = $mt->user) {
2052            $param->{author_id} = $author->id;
2053            $param->{author_name} = $author->name;
2054        }
2055        ## We do this in load_tmpl because show_error and login don't call
2056        ## build_page; so we need to set these variables here.
2057        require MT::Auth;
2058        $param->{can_logout} = MT::Auth->can_logout;
2059        $param->{script_url} = $mt->uri;
2060        $param->{mt_url} = $mt->mt_uri;
2061        $param->{script_path} = $mt->path;
2062        $param->{script_full_url} = $mt->base . $mt->uri;
2063        $param->{agent_mozilla} = ( $ENV{HTTP_USER_AGENT} || '' ) =~ /gecko/i;
2064        $param->{agent_ie} = ( $ENV{HTTP_USER_AGENT} || '' ) =~ /\bMSIE\b/;
2065    }
2066    if (!$tmpl->param('template_filename')) {
2067        if (my $fname = $tmpl->{__file}) {
2068            $fname =~ s!\\!/!g;
2069            $fname =~ s/\.tmpl$//;
2070            $param->{template_filename} = $fname;
2071        }
2072    }
2073    $tmpl->param($param);
2074}
2075
2076sub process_mt_template {
2077    my $mt = shift;
2078    my ($body) = @_;
2079    $body =~ s@<(?:_|MT)_ACTION\s+mode="([^"]+)"(?:\s+([^>]*))?>@
2080        my $mode = $1; my %args;
2081        %args = $2 =~ m/\s*(\w+)="([^"]*?)"\s*/g if defined $2; # "
2082        MT::Util::encode_html($mt->uri(mode => $mode, args => \%args));
2083    @geis;
2084    # Strip out placeholder wrappers to facilitate tmpl_* callbacks
2085    $body =~ s/<\/?MT_(\w+):(\w+)>//g;
2086    $body;
2087}
2088
2089sub build_page {
2090    my $mt = shift;
2091    my($file, $param) = @_;
2092    my $tmpl;
2093    my $mode = $mt->mode;
2094    $param->{"mode_$mode"} ||= 1;
2095    $param->{breadcrumbs} = $mt->{breadcrumbs};
2096    if ($param->{breadcrumbs}[-1]) {
2097        $param->{breadcrumbs}[-1]{is_last} = 1;
2098        $param->{page_titles} = [ reverse @{ $mt->{breadcrumbs} } ];
2099    }
2100    pop @{ $param->{page_titles} };
2101    if (my $lang_id = $mt->current_language) {
2102        $param->{local_lang_id} ||= lc $lang_id;
2103    }
2104    $param->{magic_token} = $mt->current_magic if $mt->user;
2105
2106    # List of installed packs in the application footer
2107    my @packs_installed;
2108    my $packs = $mt->find_addons('pack');
2109    if ($packs) {
2110        foreach my $pack (@$packs) {
2111            my $c = $mt->component(lc $pack->{id});
2112            if ($c) {
2113                my $label = $c->label || $pack->{label};
2114                $label = $label->() if ref($label) eq 'CODE';
2115                # if the component did not declare a label,
2116                # it isn't wanting to be visible on the app footer.
2117                next if $label eq $c->{plugin_sig};
2118                push @packs_installed, {
2119                    label => $label,
2120                    version => $c->version,
2121                    id => $c->id,
2122                };
2123            }
2124        }
2125    }
2126    @packs_installed = sort { $a->{label} cmp $b->{label} } @packs_installed;
2127    $param->{packs_installed} = \@packs_installed;
2128    $param->{portal_url} = $mt->translate("__PORTAL_URL__");
2129
2130    for my $config_field (keys %{ MT::ConfigMgr->instance->{__var} || {} }) {
2131        $param->{ $config_field . '_readonly' } = 1;
2132    }
2133
2134    my $tmpl_file = '';
2135    if (UNIVERSAL::isa($file, 'MT::Template')) {
2136        $tmpl = $file;
2137        $tmpl_file = (exists $file->{__file}) ? $file->{__file} : '';
2138    } else {
2139        $tmpl = $mt->load_tmpl($file) or return;
2140        $tmpl_file = $file unless ref($file);
2141    }
2142
2143    if (($mode && ($mode !~ m/delete/)) && ($mt->{login_again} ||
2144        ($mt->{requires_login} && !$mt->user))) {
2145        ## If it's a login screen, direct the user to where they were going
2146        ## (query params including mode and all) unless they were logging in,
2147        ## logging out, or deleting something.
2148        my $q = $mt->{query};
2149        if ($mode) {
2150            my @query = map { { name => $_, value => scalar encode_text( $q->param($_) ) }; }
2151                grep { ($_ ne 'username') && ($_ ne 'password') && ($_ ne 'submit') && ($mode eq 'logout' ? ($_ ne '__mode') : 1) } $q->param;
2152            $param->{query_params} = \@query;
2153        }
2154        $param->{login_again} = $mt->{login_again};
2155    }
2156
2157    my $blog = $mt->blog;
2158    $tmpl->context()->stash('blog', $blog) if $blog;
2159
2160    $tmpl->param($param) if $param;
2161
2162    if ($tmpl_file) {
2163        $tmpl_file = File::Basename::basename($tmpl_file);
2164        $tmpl_file =~ s/\.tmpl$//;
2165        $tmpl_file = '.' . $tmpl_file;
2166    }
2167    $mt->run_callbacks('template_param' . $tmpl_file, $mt, $tmpl->param, $tmpl);
2168
2169    my $output = $mt->build_page_in_mem($tmpl);
2170    return unless defined $output;
2171
2172    $mt->run_callbacks('template_output' . $tmpl_file, $mt, \$output, $tmpl->param, $tmpl);
2173    return $output;
2174}
2175
2176sub build_page_in_mem {
2177    my $mt = shift;
2178    my($tmpl, $param) = @_;
2179    $tmpl->param($param) if $param;
2180    my $out = $tmpl->output;
2181    return $mt->error($tmpl->errstr) unless defined $out;
2182    return $mt->translate_templatized($mt->process_mt_template($out));
2183}
2184
2185sub new_ua {
2186    my $class = shift;
2187    my ($opt) = @_;
2188    $opt ||= {};
2189    my $lwp_class = 'LWP::UserAgent';
2190    if ($opt->{paranoid}) {
2191        eval { require LWPx::ParanoidAgent; };
2192        $lwp_class = 'LWPx::ParanoidAgent' unless $@;
2193    }
2194    eval "require $lwp_class;";
2195    return undef if $@;
2196    my $cfg = $class->config;
2197    my $max_size = exists $opt->{max_size} ? $opt->{max_size} : 100_000;
2198    my $timeout = exists $opt->{timeout} ? $opt->{timeout} : $cfg->HTTPTimeout || $cfg->PingTimeout;
2199    my $proxy = exists $opt->{proxy} ? $opt->{proxy} : $cfg->HTTPProxy || $cfg->PingProxy;
2200    my $no_proxy = exists $opt->{no_proxy} ? $opt->{no_proxy} : $cfg->HTTPNoProxy || $cfg->PingNoProxy;
2201    my $agent = $opt->{agent} || 'MovableType/' . $MT::VERSION;
2202    my $interface = exists $opt->{interface} ? $opt->{interface} : $cfg->HTTPInterface || $cfg->PingInterface;
2203
2204    if ( my $localaddr = $interface ) {
2205        @LWP::Protocol::http::EXTRA_SOCK_OPTS = (
2206            LocalAddr => $localaddr,
2207            Reuse     => 1
2208        );
2209    }
2210
2211    my $ua = $lwp_class->new;
2212    $ua->max_size($max_size) if (defined $max_size) && $ua->can('max_size');
2213    $ua->agent( $agent );
2214    $ua->timeout( $timeout ) if defined $timeout;
2215    if ( defined $proxy ) {
2216        $ua->proxy( http => $proxy );
2217        my @domains = split( /,\s*/, $no_proxy ) if $no_proxy;
2218        $ua->no_proxy(@domains) if @domains;
2219    }
2220    return $ua;
2221}
2222
2223sub build_email {
2224    my $class = shift;
2225    my ( $file, $param ) = @_;
2226    my $mt = $class->instance;
2227
2228    # basically, try to load from database
2229    my $blog = $param->{blog} || undef;
2230    my $id = $file;
2231    $id =~ s/(\.tmpl|\.mtml)$//;
2232
2233    require MT::Template;
2234    my @tmpl = MT::Template->load(
2235        {
2236            ( $blog ? ( blog_id => [ $blog->id, 0 ] ) : ( blog_id => 0 ) ),
2237            identifier => $id,
2238            type       => 'email',
2239        }
2240    );
2241    my $tmpl =
2242      @tmpl
2243      ? (
2244        scalar @tmpl > 1
2245        ? ( $tmpl[0]->blog_id ? $tmpl[0] : $tmpl[1] )
2246        : $tmpl[0]
2247      )
2248      : undef;
2249
2250    # try to load from file
2251    unless ($tmpl) {
2252        local $mt->{template_dir} = 'email';
2253        $tmpl = $mt->load_tmpl($file);
2254    }
2255    return unless $tmpl;
2256
2257    my $ctx = $tmpl->context;
2258    $ctx->stash( 'blog_id', $blog->id ) if $blog;
2259    $ctx->stash( 'blog',   delete $param->{'blog'} )   if $param->{'blog'};
2260    $ctx->stash( 'entry',  delete $param->{'entry'} )  if $param->{'entry'};
2261    $ctx->stash( 'author', delete $param->{'author'} ) if $param->{'author'};
2262    $ctx->stash( 'commenter', delete $param->{'commenter'} )
2263      if $param->{'commenter'};
2264    $ctx->stash( 'comment', delete $param->{'comment'} ) if $param->{'comment'};
2265    $ctx->stash( 'category', delete $param->{'category'} )
2266      if $param->{'category'};
2267    $ctx->stash( 'ping', delete $param->{'ping'} ) if $param->{'ping'};
2268
2269    foreach my $p (%$param) {
2270        if ( ref($p) ) {
2271            $tmpl->param( $p, $param->{$p} );
2272        }
2273    }
2274    return $mt->build_page_in_mem( $tmpl, $param );
2275}
2276
2277sub get_next_sched_post_for_user {
2278    my ( $author_id, @further_blog_ids ) = @_;
2279    require MT::Permission;
2280    my @perms = MT::Permission->load( { author_id => $author_id }, {} );
2281    my @blogs = @further_blog_ids;
2282    for my $perm (@perms) {
2283        next
2284          unless ( $perm->can_edit_config
2285            || $perm->can_publish_post
2286            || $perm->can_edit_all_posts );
2287        push @blogs, $perm->blog_id;
2288    }
2289    my $next_sched_utc = undef;
2290    require MT::Entry;
2291    for my $blog_id (@blogs) {
2292        my $blog           = MT::Blog->load($blog_id)
2293            or next;
2294        my $earliest_entry = MT::Entry->load(
2295            {
2296                status  => MT::Entry::FUTURE(),
2297                blog_id => $blog_id
2298            },
2299            { 'sort' => 'created_on' }
2300        );
2301        if ($earliest_entry) {
2302            my $entry_utc =
2303              MT::Util::ts2iso( $blog, $earliest_entry->created_on );
2304            if ( $entry_utc < $next_sched_utc || !defined($next_sched_utc) ) {
2305                $next_sched_utc = $entry_utc;
2306            }
2307        }
2308    }
2309    return $next_sched_utc;
2310}
2311
2312our %Commenter_Auth;
2313
2314sub init_commenter_authenticators {
2315    my $self = shift;
2316    my $auths = $self->registry("commenter_authenticators") || {};
2317    foreach my $auth ( keys %$auths ) {
2318        delete $auths->{$auth}
2319          if exists( $auths->{$auth}->{condition} )
2320          && !( $auths->{$auth}->{condition}->() );
2321    }
2322    %Commenter_Auth = %$auths;
2323    $Commenter_Auth{$_}{key} ||= $_ for keys %Commenter_Auth;
2324}
2325
2326sub commenter_authenticator {
2327    my $self = shift;
2328    my ($key) = @_;
2329    %Commenter_Auth or $self->init_commenter_authenticators();
2330    return $Commenter_Auth{$key};
2331}
2332
2333sub commenter_authenticators {
2334    my $self = shift;
2335    %Commenter_Auth or $self->init_commenter_authenticators();
2336    return values %Commenter_Auth;
2337}
2338
2339sub _commenter_auth_params {
2340    my ( $key, $blog_id, $entry_id, $static ) = @_;
2341    my $params = {
2342        blog_id => $blog_id,
2343        static  => $static,
2344    };
2345    $params->{entry_id} = $entry_id if defined $entry_id;
2346    return $params;
2347}
2348
2349sub _openid_commenter_condition {
2350    eval "require Digest::SHA1;";
2351    return $@ ? 0 : 1;
2352}
2353
2354sub core_commenter_authenticators {
2355    return {
2356        'OpenID' => {
2357            class      => 'MT::Auth::OpenID',
2358            label      => 'OpenID',
2359            login_form => <<OpenID,
2360<form method="post" action="<mt:var name="script_url">">
2361<input type="hidden" name="__mode" value="login_external" />
2362<input type="hidden" name="blog_id" value="<mt:var name="blog_id">" />
2363<input type="hidden" name="entry_id" value="<mt:var name="entry_id">" />
2364<input type="hidden" name="static" value="<mt:var name="static" escape="html">" />
2365<fieldset>
2366<mtapp:setting
2367    id="openid_display"
2368    label="<__trans phrase="OpenID URL">"
2369    hint="<__trans phrase="Sign in using your OpenID identity.">">
2370<input type="hidden" name="key" value="OpenID" />
2371<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%;" />
2372    <p class="hint"><__trans phrase="OpenID is an open and decentralized single sign-on identity system."></p>
2373</mtapp:setting>
2374<img src="<mt:var name="static_uri">images/comment/openid_enabled.png" class="right" />
2375<div class="actions-bar actions-bar-login">
2376    <div class="actions-bar-inner pkg actions">
2377        <button
2378            type="submit"
2379            class="primary-button"
2380            ><__trans phrase="Sign in"></button>
2381    </div>
2382</div>
2383<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>
2384</fieldset>
2385</form>
2386OpenID
2387            login_form_params => \&_commenter_auth_params,
2388            condition         => \&_openid_commenter_condition,
2389            logo              => 'images/comment/signin_openid.png',
2390            logo_small        => 'images/comment/openid_logo.png',
2391        },
2392        'LiveJournal' => {
2393            class      => 'MT::Auth::LiveJournal',
2394            label      => 'LiveJournal',
2395            login_form => <<LiveJournal,
2396<form method="post" action="<mt:var name="script_url">">
2397<input type="hidden" name="__mode" value="login_external" />
2398<input type="hidden" name="blog_id" value="<mt:var name="blog_id">" />
2399<input type="hidden" name="entry_id" value="<mt:var name="entry_id">" />
2400<input type="hidden" name="static" value="<mt:var name="static" escape="html">" />
2401<input type="hidden" name="key" value="LiveJournal" />
2402<fieldset>
2403<mtapp:setting
2404    id="livejournal_display"
2405    label="<__trans phrase="Your LiveJournal Username">"
2406    hint="<__trans phrase="Sign in using your Vox blog URL">">
2407<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%;" />
2408</mtapp:setting>
2409<div class="actions-bar actions-bar-login">
2410    <div class="actions-bar-inner pkg actions">
2411        <button
2412            type="submit"
2413            class="primary-button"
2414            ><__trans phrase="Sign in"></button>
2415    </div>
2416</div>
2417<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>
2418</fieldset>
2419</form>
2420LiveJournal
2421            login_form_params => \&_commenter_auth_params,
2422            condition         => \&_openid_commenter_condition,
2423            logo              => 'images/comment/signin_livejournal.png',
2424            logo_small        => 'images/comment/livejournal_logo.png',
2425        },
2426        'Vox' => {
2427            class      => 'MT::Auth::Vox',
2428            label      => 'Vox',
2429            login_form => <<Vox,
2430<form method="post" action="<mt:var name="script_url">">
2431<input type="hidden" name="__mode" value="login_external" />
2432<input type="hidden" name="blog_id" value="<mt:var name="blog_id">" />
2433<input type="hidden" name="entry_id" value="<mt:var name="entry_id">" />
2434<input type="hidden" name="static" value="<mt:var name="static" escape="html">" />
2435<input type="hidden" name="key" value="Vox" />
2436<fieldset>
2437<mtapp:setting
2438    id="vox_display"
2439    label="<__trans phrase="Your Vox Blog URL">">
2440http:// <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
2441</mtapp:setting>
2442<div class="actions-bar actions-bar-login">
2443    <div class="actions-bar-inner pkg actions">
2444        <button
2445            type="submit"
2446            class="primary-button"
2447            ><__trans phrase="Sign in"></button>
2448    </div>
2449</div>
2450<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>
2451</fieldset>
2452</form>
2453Vox
2454            login_form_params => \&_commenter_auth_params,
2455            condition         => \&_openid_commenter_condition,
2456            logo              => 'images/comment/signin_vox.png',
2457            logo_small        => 'images/comment/vox_logo.png',
2458        },
2459        'TypeKey' => {
2460            class      => 'MT::Auth::TypeKey',
2461            label      => 'TypeKey',
2462            login_form => <<TypeKey,
2463<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>
2464<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>
2465TypeKey
2466            login_form_params => sub {
2467                my ( $key, $blog_id, $entry_id, $static ) = @_;
2468                my $entry = MT::Entry->load($entry_id) if $entry_id;
2469
2470                ## TypeKey URL
2471                require MT::Template::Context;
2472                my $ctx = MT::Template::Context->new;
2473                $ctx->stash( 'blog_id', $blog_id );
2474                my $blog = MT::Blog->load($blog_id);
2475                $ctx->stash( 'blog',  $blog );
2476                $ctx->stash( 'entry', $entry );
2477                my $params = {};
2478                $params->{tk_signin_url} =
2479                  MT::Template::Context::_hdlr_remote_sign_in_link( $ctx,
2480                    { static => $static } );
2481                return $params;
2482            },
2483            logo => 'images/comment/signin_typekey.png',
2484            logo_small        => 'images/comment/typekey_logo.png',
2485        },
2486    };
2487}
2488
2489our %Captcha_Providers;
2490
2491sub captcha_provider {
2492    my $self = shift;
2493    my ($key) = @_;
2494    $self->init_captcha_providers() unless %Captcha_Providers;
2495    return $Captcha_Providers{$key};
2496}
2497
2498sub captcha_providers {
2499    my $self = shift;
2500    $self->init_captcha_providers() unless %Captcha_Providers;
2501    my $def  = delete $Captcha_Providers{'mt_default'};
2502    my @vals = values %Captcha_Providers;
2503    if ( defined($def) && $def->{condition}->() ) {
2504        unshift @vals, $def;
2505    }
2506    @vals;
2507}
2508
2509sub core_captcha_providers {
2510    return {
2511        'mt_default' => {
2512            label     => 'Movable Type default',
2513            class     => 'MT::Util::Captcha',
2514            condition => sub {
2515                require MT::Util::Captcha;
2516                if ( my $error = MT::Util::Captcha->check_availability ) {
2517                    return 0;
2518                }
2519                1;
2520            },
2521        }
2522    };
2523}
2524
2525sub init_captcha_providers {
2526    my $self = shift;
2527    my $providers = $self->registry("captcha_providers") || {};
2528    foreach my $provider ( keys %$providers ) {
2529        delete $providers->{$provider}
2530          if exists( $providers->{$provider}->{condition} )
2531          && !( $providers->{$provider}->{condition}->() );
2532    }
2533    %Captcha_Providers = %$providers;
2534    $Captcha_Providers{$_}{key} ||= $_ for keys %Captcha_Providers;
2535}
2536
2537sub effective_captcha_provider {
2538    my $class = shift;
2539    my ($key) = @_;
2540    return undef unless $key;
2541    my $cp = $class->captcha_provider($key) or return;
2542    if ( exists $cp->{condition} ) {
2543        return undef unless $cp->{condition}->();
2544    }
2545    my $pkg = $cp->{class};
2546    $pkg =~ s/;//g;
2547    eval "require $pkg" or return;
2548    return $cp->{class};
2549}
2550
2551sub handler_to_coderef {
2552    my $pkg = shift;
2553    my ( $name, $delayed ) = @_;
2554
2555    return $name if ref($name) eq 'CODE';
2556    return undef unless defined $name && $name ne '';
2557
2558    my $code;
2559    if ( $name !~ m/->/ ) {
2560
2561        # check for Package::Routine first; if defined, return coderef
2562        no strict 'refs';
2563        $code = \&$name if defined &$name;
2564        return $code if $code;
2565    }
2566
2567    my $component;
2568    if ( $name =~ m!^\$! ) {
2569        if ( $name =~ s/^\$(\w+)::// ) {
2570            $component = $1;
2571        }
2572    }
2573    if ( $name =~ m/^\s*sub\s*\{/s ) {
2574        $code = eval $name or die $@;
2575
2576        if ($component) {
2577            return sub {
2578                my $mt_inst = MT->instance;
2579                local $mt_inst->{component} = $component;
2580                $code->(@_);
2581            };
2582        }
2583        else {
2584            return $code;
2585        }
2586    }
2587
2588    my $hdlr_pkg = $name;
2589    my $method;
2590    if ( $hdlr_pkg =~ s/(->|::)([^:]+)$// ) {    # strip routine name
2591        $method = $2 if $1 eq '->';
2592    }
2593    if ( !defined(&$name) && !$pkg->can( 'AUTOLOAD' ) ) {
2594
2595        # The delayed option will return a coderef that delays the loading
2596        # of the package holding the handler routine.
2597        if ($delayed) {
2598            if ($method) {
2599                return sub {
2600                    eval "# line " . __LINE__ . " " . __FILE__ . "\nrequire $hdlr_pkg;"
2601                      or Carp::confess(
2602                        "failed loading package $hdlr_pkg for routine $name: $@");
2603                    my $mt_inst = MT->instance;
2604                    local $mt_inst->{component} = $component
2605                      if $component;
2606                    return $hdlr_pkg->$method(@_);
2607                };
2608            }
2609            else {
2610                return sub {
2611                    eval "# line " . __LINE__ . " " . __FILE__ . "\nrequire $hdlr_pkg;"
2612                      or Carp::confess(
2613                        "failed loading package $hdlr_pkg for routine $name: $@");
2614                    my $mt_inst = MT->instance;
2615                    local $mt_inst->{component} = $component
2616                      if $component;
2617                    no strict 'refs';
2618                    my $hdlr = \&$name;
2619                    use strict 'refs';
2620                    return $hdlr->(@_);
2621                };
2622            }
2623        }
2624        else {
2625            eval "# line " . __LINE__ . " " . __FILE__ . "\nrequire $hdlr_pkg;"
2626              or Carp::confess(
2627                "failed loading package $hdlr_pkg for routine $name: $@");
2628        }
2629    }
2630    if ($method) {
2631        $code = sub {
2632            my $mt_inst = MT->instance;
2633            local $mt_inst->{component} = $component
2634              if $component;
2635            return $hdlr_pkg->$method(@_);
2636        };
2637    }
2638    else {
2639        if ($component) {
2640            $code = sub {
2641                no strict 'refs';
2642                my $hdlr = (
2643                    defined &$name ? \&$name
2644                    : ( $pkg->can( 'AUTOLOAD' ) ? \&$name
2645                        : undef )
2646                );
2647                use strict 'refs';
2648                if ($hdlr) {
2649                    my $mt_inst = MT->instance;
2650                    local $mt_inst->{component} = $component
2651                      if $component;
2652                    return $hdlr->(@_);
2653                }
2654                return undef;
2655              }
2656        }
2657        else {
2658            no strict 'refs';
2659            $code =
2660              (
2661                defined &$name
2662                ? \&$name
2663                : ( $hdlr_pkg->can( 'AUTOLOAD' ) ? \&$name : undef )
2664              );
2665        }
2666    }
2667    return $code;
2668}
2669
2670sub help_url {
2671    my $pkg = shift;
2672    my ( $append ) = @_;
2673
2674    my $url = $pkg->config->HelpURL;
2675    return $url if defined $url;
2676    $url = $pkg->translate('http://www.movabletype.org/documentation/');
2677    if ( $append ) {
2678        $url .= $append;
2679    }
2680    $url;
2681}
2682
2683sub register_refresh_cache_event {
2684    my $pkg = shift;
2685    my ($callback) = @_;
2686    return unless $callback;
2687
2688    MT->_register_core_callbacks({
2689        "$callback" => \&refresh_cache,
2690    });
2691}
2692
2693sub refresh_cache {
2694    my ($cb, %args) = @_;
2695
2696    require MT::Cache::Negotiate;
2697    my $cache_driver = MT::Cache::Negotiate->new();
2698    return unless $cache_driver;
2699
2700    $cache_driver->flush_all();
2701}
2702
2703sub DESTROY {
2704    # save_config here so not to miss any dirty config change to persist
2705    # particulary for those which does not construct MT::App.
2706    $_[0]->config->save_config();
2707}
2708
27091;
2710
2711__END__
2712
2713=head1 NAME
2714
2715MT - Movable Type
2716
2717=head1 SYNOPSIS
2718
2719    use MT;
2720    my $mt = MT->new;
2721    $mt->rebuild(BlogID => 1)
2722        or die $mt->errstr;
2723
2724=head1 DESCRIPTION
2725
2726The I<MT> class is the main high-level rebuilding/pinging interface in the
2727Movable Type library. It handles all rebuilding operations. It does B<not>
2728handle any of the application functionality--for that, look to I<MT::App> and
2729I<MT::App::CMS>, both of which subclass I<MT> to handle application requests.
2730
2731=head1 PLUGIN APPLICATIONS
2732
2733At any given time, the user of the Movable Type platform is
2734interacting with either the core Movable Type application, or a plugin
2735application (or "sub-application").
2736
2737A plugin application is a plugin with a user interface that inherits
2738functionality from Movable Type, and appears to the user as a
2739component of Movable Type. A plugin application typically has its own
2740templates displaying its own special features; but it inherits some
2741templates from Movable Type, such as the navigation chrome and error
2742pages.
2743
2744=head2 The MT Root and the Application Root
2745
2746To locate assets of the core Movable Type application and any plugin
2747applications, the platform uses two directory paths, C<mt_dir> and
2748C<app_dir>. These paths are returned by the MT class methods with the
2749same names, and some other methods return derivatives of these paths.
2750
2751Conceptually, mt_dir is the root of the Movable Type installation, and
2752app_dir is the root of the "currently running application", which
2753might be Movable Type or a plugin application. It is important to
2754understand the distinction between these two values and what each is
2755used for.
2756
2757The I<mt_dir> is the absolute path to the directory where MT itself is
2758located. Most importantly, the MT configuration file and the CGI scripts that
2759bootstrap an MT request are found here. This directory is also the
2760default base path under which MT's core templates are found (but this
2761can be overridden using the I<TemplatePath> configuration setting).
2762
2763Likewise, the I<app_dir> is the directory where the "current"
2764application's assets are rooted. The platform will search for
2765application templates underneath the I<app_dir>, but this search also
2766searches underneath the I<mt_dir>, allowing the application to make
2767use of core headers, footers, error pages, and possibly other
2768templates.
2769
2770In order for this to be useful, the plugin's templates and
2771code should all be located underneath the same directory. The relative
2772path from the I<app_dir> to the application's templates is
2773configurable. For details on how to indicate the location of your
2774plugin's templates, see L<MT::App>.
2775
2776=head2 Finding the Root Paths
2777
2778When a plugin application initializes its own application class (a
2779subclass of MT::App), the I<mt_dir> should be discovered and passed
2780constructor. This comes either from the C<Directory> parameter or the
2781C<Config> parameter.
2782
2783Since plugins are loaded from a descendent of the MT root directory,
2784the plugin bootstrap code can discover the MT configuration file (and thus
2785the MT root directory) by traversing the filesystem; the absolute path
2786to that file can be passed as the C<Config> parameter to
2787MT::App::new. Working code to do this can be found in the
2788examples/plugins/mirror/mt-mirror.cgi file.
2789
2790The I<app_dir>, on the other hand, always derives from the location of
2791the currently-running program, so it typically does not need to be
2792specified.
2793
2794=head1 USAGE
2795
2796I<MT> has the following interface. On failure, all methods return C<undef>
2797and set the I<errstr> for the object or class (depending on whether the
2798method is an object or class method, respectively); look below at the section
2799L<ERROR HANDLING> for more information.
2800
2801=head2 MT->new( %args )
2802
2803Constructs a new I<MT> instance and returns that object. Returns C<undef>
2804on failure.
2805
2806I<new> will also read your MT configuration file (provided that it can find it--if
2807you find that it can't, take a look at the I<Config> directive, below). It
2808will also initialize the chosen object driver; the default is the C<DBM>
2809object driver.
2810
2811I<%args> can contain:
2812
2813=over 4
2814
2815=item * Config
2816
2817Path to the MT configuration file.
2818
2819If you do not specify a path, I<MT> will try to find your MT configuration file
2820in the current working directory.
2821
2822=item * Directory
2823
2824Path to the MT home directory.
2825
2826If you do not specify a path, I<MT> will try to find the MT directory using
2827the discovered path of the MT configuration file.
2828
2829=back
2830
2831=head2 $mt->init
2832
2833Initializes the Movable Type instance, including registration of basic
2834resources and callbacks. This method also invokes the C<init_config>
2835and C<init_plugins> methods.
2836
2837=head2 MT->instance
2838
2839MT and all it's subclasses are now singleton classes, meaning you can only
2840have one instance per package. MT->instance() returns the active instance.
2841MT->new() is now an alias to instance_of.
2842
2843=head2 $class->instance_of
2844
2845Returns the singleton instance of the MT subclass identified by C<$class>.
2846
2847=head2 $class->construct
2848
2849Constructs a new instance of the MT subclass identified by C<$class>.
2850
2851=head2 MT->set_instance
2852
2853Assigns the active MT instance object. This value is returned when
2854C<MT-E<gt>instance> is invoked.
2855
2856=head2 $mt->find_config($params)
2857
2858Handles the discovery of the MT configuration file. The path and filename
2859for the configuration file is returned as the result. The C<$params>
2860parameter is a reference to the hash of settings passed to the MT
2861constructor.
2862
2863=head2 $mt->init_config($params)
2864
2865Reads the MT configuration settingss from the MT configuration file
2866and settings from database (L<MT::Config>).
2867
2868The C<$params> parameter is a reference to the hash of settings passed to
2869the MT constructor.
2870
2871=head2 $mt->init_plugins
2872
2873Loads any discoverable plugins that are available. This is called from
2874the C<init> method, after the C<init_config> method has loaded the
2875configuration settings.
2876
2877=head2 $mt->init_tasks
2878
2879Registers the standard set of periodic tasks that Movable Type provides
2880and then invokes the C<init_tasks> method for each available plugin.
2881
2882=head2 MT->run_tasks
2883
2884Initializes the tasks, running C<init_tasks> and invokes the task system
2885through L<MT::TaskMgr> to run any registered tasks that are pending
2886execution. See L<MT::TaskMgr> for further documentation.
2887
2888=head2 MT->unplug
2889
2890Removes the global reference to the MT instance.
2891
2892=head2 MT::log( $message ) or $mt->log( $message )
2893
2894Adds an entry to the application's log table. Also writes message to
2895STDERR which is typically routed to the web server's error log.
2896
2897=head2 $mt->server_path, $mt->mt_dir
2898
2899Both of these methods return the physical file path to the directory
2900that is the home of the MT installation. This would be the value of
2901the 'Directory' parameter given in the MT constructor, or would be
2902determined based on the path of the configuration file.
2903
2904=head2 $mt->app_dir
2905
2906Returns the physical file path to the active application directory. This
2907is determined by the directory of the active script.
2908
2909=head2 $mt->config_dir
2910
2911Returns the path to the MT configuration file.
2912
2913=head2 $mt->config([$setting[, $value]])
2914
2915This method is used to get and set configuration settings. When called
2916without any parameters, it returns the active MT::ConfigMgr instance
2917used by the application.
2918
2919Specifying the C<$setting> parameter will return the value for that setting.
2920When passing the C<$value> parameter, this will update the config object,
2921assigning that value for the named C<$setting>.
2922
2923=head2 $mt->user_class
2924
2925Returns the package name for the class used for user authentication.
2926This is typically L<MT::Author>.
2927
2928=head2 $mt->request([$element[,$data]])
2929
2930The request method provides a request-scoped storage object. It is an
2931access interface for the L<MT::Request> package. Calling without any
2932parameters will return the L<MT::Request> instance.
2933
2934When called with the C<$element> parameter, the data stored for that
2935element is returned (or undef, if it didn't exist). When called with
2936the C<$data> parameter, it will store the data into the specified
2937element in the request object.
2938
2939All values placed in the request object are lost at the end of the
2940request. If the running application is not a web-based application,
2941the request object exists for the lifetime of the process and is
2942released when the process ends.
2943
2944See the L<MT::Request> package for more information.
2945
2946=head2 MT->new_ua
2947
2948Returns a new L<LWP::UserAgent> instance that is configured according to the
2949Movable Type configuration settings (specifically C<HTTPInterface>, C<HTTPTimeout>, C<HTTPProxy> and C<HTTPNoProxy>). The agent string is set
2950to "MovableType/(version)" and is also limited to receiving a response of
2951100,000 bytes by default (you can override this by using the 'max_size'
2952method on the returned instance). Using this method is recommended for
2953any HTTP requests issued by Movable Type since it uses the MT configuration
2954settings to prepare the UserAgent object.
2955
2956=head2 $mt->ping( %args )
2957
2958Sends all configured XML-RPC pings as a way of notifying other community
2959sites that your blog has been updated.
2960
2961I<%args> can contain:
2962
2963=over 4
2964
2965=item * Blog
2966
2967An I<MT::Blog> object corresponding to the blog for which you would like to
2968send the pings.
2969
2970Either this or C<BlogID> is required.
2971
2972=item * BlogID
2973
2974The ID of the blog for which you would like to send the pings.
2975
2976Either this or C<Blog> is required.
2977
2978=back
2979
2980=head2 $mt->ping_and_save( %args )
2981
2982Handles the task of issuing any pending ping operations for a given
2983entry and then saving that entry back to the database.
2984
2985The I<%args> hash should contain an element named C<Entry> that is a
2986reference to a L<MT::Entry> object.
2987
2988=head2 $mt->needs_ping(%param)
2989
2990Returns a list of URLs that have not been pinged for a given entry. Named
2991parameters for this method are:
2992
2993=over 4
2994
2995=item Entry
2996
2997The L<MT::Entry> object to examine.
2998
2999=item Blog
3000
3001The L<MT::Blog> object that is the parent of the entry given.
3002
3003=back
3004
3005The return value is an array reference of URLs that have not been pinged
3006for the given entry.
3007
3008An empty list is returned for entries that have a non 'RELEASE' status.
3009
3010=head2 $mt->update_ping_list($blog)
3011
3012Returns a list of URLs for ping services that have been configured to
3013be notified when posting new entries.
3014
3015=head2 $mt->set_language($tag)
3016
3017Loads the localization plugin for the language specified by I<$tag>, which
3018should be a valid and supported language tag--see I<supported_languages> to
3019obtain a list of supported languages.
3020
3021The language is set on a global level, and affects error messages and all
3022text in the administration system.
3023
3024This method can be called as either a class method or an object method; in
3025other words,
3026
3027    MT->set_language($tag)
3028
3029will also work. However, the setting will still be global--it will not be
3030specified to the I<$mt> object.
3031
3032The default setting--set when I<MT::new> is called--is U.S. English. If a
3033I<DefaultLanguage> is set in the MT configuration file, the default is then
3034set to that language.
3035
3036=head2 MT->translate($str[, $param, ...])
3037
3038Translates I<$str> into the currently-set language (set by I<set_language>),
3039and returns the translated string. Any parameters following I<$str> are
3040passed through to the C<maketext> method of the active localization module.
3041
3042=head2 MT->translate_templatized($str)
3043
3044Translates a string that has embedded E<lt>MT_TRANSE<gt> tags. These
3045tags identify the portions of the string that require localization.
3046Each tag is processed separately and passed through the MT->translate
3047method. Examples (used in your application's HTML::Template templates):
3048
3049    <p><MT_TRANS phrase="Hello, world"></p>
3050
3051and
3052
3053    <p><MT_TRANS phrase="Hello, [_1]" params="<TMPL_VAR NAME=NAME>"></p>
3054
3055=head2 $mt->trans_error( $str[, $arg1, $arg2] )
3056
3057Translates I<$str> into the currently-set language (set by I<set_language>),
3058and assigns it as the active error for the MT instance. It returns undef,
3059which is the usual return value upon generating an error in the application.
3060So when an error occurs, the typical return result would be:
3061
3062    if ($@) {
3063        return $app->trans_error("An error occurred: [_1]", $@);
3064    }
3065
3066The optional I<$arg1> (and so forth) parameters are passed as parameters to
3067any parameterized error message.
3068
3069=head2 $mt->current_language
3070
3071Returns the language tag for the currently-set language.
3072
3073=head2 MT->supported_languages
3074
3075Returns a reference to an associative array mapping language tags to their
3076proper names. For example:
3077
3078    use MT;
3079    my $langs = MT->supported_languages;
3080    print map { $_ . " => " . $langs->{$_} . "\n" } keys %$langs;
3081
3082=head2 MT->language_handle
3083
3084Returns the active MT::L10N language instance for the active language.
3085
3086=head2 MT->add_plugin($plugin)
3087
3088Adds the plugin described by $plugin to the list of plugins displayed
3089on the welcome page. The argument should be an object of the
3090I<MT::Plugin> class.
3091
3092=head2 MT->all_text_filters
3093
3094Returns a reference to a hash containing the registry of text filters.
3095
3096=head2 MT->apply_text_filters($str, \@filters)
3097
3098Applies the set of filters I<\@filters> to the string I<$str> and returns
3099the result (the filtered string).
3100
3101I<\@filters> should be a reference to an array of filter keynames--these
3102are the short names passed in as the first argument to I<add_text_filter>.
3103I<$str> should be a scalar string to be filtered.
3104
3105If one of the filters listed in I<\@filters> is not found in the list of
3106registered filters (that is, filters added through I<add_text_filter>),
3107it will be skipped silently. Filters are executed in the order in which they
3108appear in I<\@filters>.
3109
3110As it turns out, the I<MT::Entry::text_filters> method returns a reference
3111to the list of text filters to be used for that entry. So, for example, to
3112use this method to apply filters to the main entry text for an entry
3113I<$entry>, you would use
3114
3115    my $out = MT->apply_text_filters($entry->text, $entry->text_filters);
3116
3117=head2 MT->add_callback($meth, $priority, $plugin, $code)
3118
3119Registers a new callback handler for a particular registered callback.
3120
3121The first parameter is the name of the callback method. The second
3122parameter is a priority (a number in the range of 1-10) which will control
3123the order that the handler is executed in relation to other handlers. If
3124two handlers register with the same priority, they will be executed in
3125the order that they registered. The third parameter is a C<MT::Plugin> object
3126reference that is associated with the handler (this parameter is optional).
3127The fourth parameter is a code reference that is invoked to handle the
3128callback. For example:
3129
3130    MT->add_callback('BuildFile', 1, undef, \&rebuild_file_hdlr);
3131
3132The code reference should expect to receive an object of type
3133L<MT::Callback> as its first argument. This object is used to
3134communicate errors to the caller:
3135
3136    sub rebuild_file_hdlr {
3137        my ($cb, ...) = @_;
3138        if (something bad happens) {
3139            return $cb->error("Something bad happened!");
3140        }
3141    }
3142
3143Other parameters to the callback function depend on the callback point.
3144
3145The treatment of the error string depends on the callback point.
3146Typically, either it is ignored or the user's action fails and the
3147error message is displayed.
3148
3149The value returned from this method is the new L<MT::Callback> object.
3150
3151=head2 MT->remove_callback($callback)
3152
3153Removes a callback that was previously registered.
3154
3155=head2 MT->register_callbacks([...])
3156
3157Registers several callbacks simultaneously. Each element in the array
3158parameter given should be a hashref containing these elements: C<name>,
3159C<priority>, C<plugin> and C<code>.
3160
3161=head2 MT->run_callbacks($meth[, $arg1, $arg2, ...])
3162
3163Invokes a particular callback, running any associated callback handlers.
3164
3165The first parameter is the name of the callback to execute. This is one
3166of the global callback methods (see L<Callbacks> section) or can be
3167a class-specific method that includes the package name associated with
3168the callback.
3169
3170The remaining arguments are passed through to any callback handlers that
3171are invoked.
3172
3173For "Filter"-type callbacks, this routine will return a 0 if any of the
3174handlers return a false result. If all handlers return a true result,
3175a value of 1 is returned.
3176
3177Example:
3178
3179    MT->run_callbacks('MyClass::frobnitzes', \@whirlygigs);
3180
3181Which would execute any handlers that registered in this fashion:
3182
3183    MT->add_callback('MyClass::frobnitzes', 4, $plugin, \&frobnitz_hdlr);
3184
3185=head2 MT->run_callback($cb[, $arg1, $arg2, ...])
3186
3187An internal routine used by C<run_callbacks> to invoke a single
3188L<MT::Callback>.
3189
3190=head2 callback_error($str)
3191
3192This routine is used internally by C<MT::Callback> to set any error response
3193that comes from invoking a callback.
3194
3195=head2 callback_errstr
3196
3197This internal routine returns the error response stored using the
3198C<callback_error> routine.
3199
3200=head2 MT->product_code
3201
3202The product code identifying the Movable Type product that is installed.
3203This is either 'MTE' for Movable Type Enterprise or 'MT' for the
3204non-Enterprise product.
3205
3206=head2 MT->product_name
3207
3208The name of the Movable Type product that is installed. This is either
3209'Movable Type Enterprise' or 'Movable Type Publishing Platform'.
3210
3211=head2 MT->product_version
3212
3213The version number of the product. This is different from the C<version_id>
3214and C<version_number> methods as they report the API version information.
3215
3216=head2 MT->version_id
3217
3218Returns the API version of MT (including any beta/alpha designations).
3219
3220=head2 MT->version_number
3221
3222Returns the numeric API version of MT (without any beta/alpha designations).
3223For example, if I<version_id> returned C<2.5b1>, I<version_number> would
3224return C<2.5>.
3225
3226=head2 MT->schema_version
3227
3228Returns the version of the MT database schema.
3229
3230=head2 MT->version_slug
3231
3232Returns a string of text that is appended to emails sent through the
3233C<build_email> method.
3234
3235=head2 $mt->publisher
3236
3237Returns the L<MT::WeblogPublisher> object that is used for managing the
3238MT publishing process. See L<MT::WeblogPublisher> for more information.
3239
3240=head2 $mt->rebuild
3241
3242An alias to L<MT::WeblogPublisher::rebuild>. See L<MT::WeblogPublisher>
3243for documentation of this method.
3244
3245=head2 $mt->rebuild_entry
3246
3247An alias to L<MT::WeblogPublisher::rebuild_entry>. See L<MT::WeblogPublisher>
3248for documentation of this method.
3249
3250=head2 $mt->rebuild_indexes
3251
3252An alias to L<MT::WeblogPublisher::rebuild_indexes>. See
3253L<MT::WeblogPublisher> for documentation of this method.
3254
3255=head2 $mt->build_email($file, $param)
3256
3257Loads a template from the application's 'email' template directory and
3258processes it as a HTML::Template. The C<$param> argument is a hash reference
3259of parameter data for the template. The return value is the output of the
3260template.
3261
3262=head2 MT::get_next_sched_post_for_user($author_id, @blog_ids)
3263
3264This is an internal routine used by L<MT::XMLRPCServer> and the
3265getNextScheduled XMLRPC method to determine the timestamp for the next
3266entry that is scheduled for publishing. The return value is the timestamp
3267in UTC time in the format "YYYY-MM-DDTHH:MM:SSZ".
3268
3269=head1 ERROR HANDLING
3270
3271On an error, all of the above methods return C<undef>, and the error message
3272can be obtained by calling the method I<errstr> on the class or the object
3273(depending on whether the method called was a class method or an instance
3274method).
3275
3276For example, called on a class name:
3277
3278    my $mt = MT->new or die MT->errstr;
3279
3280Or, called on an object:
3281
3282    $mt->rebuild(BlogID => $blog_id)
3283        or die $mt->errstr;
3284
3285=head1 DEBUGGING
3286
3287MT has a package variable C<$MT::DebugMode> which is assigned through
3288your MT configuration file (DebugMode setting). If this is set to
3289any non-zero value, MT applications will display any C<warn>'d
3290statements to a panel that is displayed within the app.
3291
3292The DebugMode is a bit-wise setting and offers the following options:
3293
3294    1 - Display debug messages
3295    2 - Display a stack trace for messages captured
3296    4 - Lists queries issued by Data::ObjectDriver
3297    8 - Reports on MT templates that take more than 1/4 second to build*
3298    128 - Outputs app-level request/response information to STDERR.
3299
3300These can be combined, so if you want to display queries and debug messages,
3301use a DebugMode of 5 for instance.
3302
3303You may also use the local statement to temporarily apply a particular bit,
3304if you want to scope the debug messages you receive to a block of code:
3305
3306    local $MT::DebugMode |= 4;  # show me the queries for the following
3307    my $obj = MT::Entry->load({....});
3308
3309*DebugMode bit 8 actually outputs it's messages to STDERR (which typically
3310is sent to your web server's error log).
3311
3312=head1 CALLBACKS
3313
3314Movable Type has a variety of hook points at which a plugin can attach
3315a callback.
3316
3317In each case, the first parameter is an L<MT::Callback> object which
3318can be used to pass error information back to the caller.
3319
3320The app-level callbacks related to rebuilding are documented
3321in L<MT::WeblogPublisher>. The specific apps document the callbacks
3322which they invoke.
3323
3324=head2 NewUserProvisioning($cb, $user)
3325
3326This callback is invoked when a user is being added to Movable Type.
3327Movable Type itself registers for this callback (with a priority of 5)
3328to provision the user with a new weblog if the system has been configured
3329to do so.
3330
3331=head2 post_init($cb, \%param)
3332
3333This callback is invoked when MT is initialized and ready to run.
3334This callback is invoked after MT initialized addons, plugins, schema
3335and permissions.  The arguments passed to initialize MT is passed
3336through to the callback.
3337
3338=head1 LICENSE
3339
3340The license that applies is the one you agreed to when downloading
3341Movable Type.
3342
3343=head1 AUTHOR & COPYRIGHT
3344
3345Except where otherwise noted, MT is Copyright 2001-2008 Six Apart.
3346All rights reserved.
3347
3348=cut
Note: See TracBrowser for help on using the browser.