root/branches/release-38/lib/MT.pm.pre @ 2274

Revision 2274, 106.0 kB (checked in by fumiakiy, 19 months ago)

Applied Jay's patch to allow plugins to have extlib directory. BugId:69660
  • 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                        $lib = File::Spec->catdir( $plugin_full_path, $lib );
1318                        unshift @INC, $lib if -d $lib;
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                push @packs_installed, {
2116                    label => $label,
2117                    version => $c->version,
2118                    id => $c->id,
2119                };
2120            }
2121        }
2122    }
2123    @packs_installed = sort { $a->{label} cmp $b->{label} } @packs_installed;
2124    $param->{packs_installed} = \@packs_installed;
2125    $param->{portal_url} = $mt->translate("__PORTAL_URL__");
2126
2127    for my $config_field (keys %{ MT::ConfigMgr->instance->{__var} || {} }) {
2128        $param->{ $config_field . '_readonly' } = 1;
2129    }
2130
2131    my $tmpl_file = '';
2132    if (UNIVERSAL::isa($file, 'MT::Template')) {
2133        $tmpl = $file;
2134        $tmpl_file = (exists $file->{__file}) ? $file->{__file} : '';
2135    } else {
2136        $tmpl = $mt->load_tmpl($file) or return;
2137        $tmpl_file = $file unless ref($file);
2138    }
2139
2140    if (($mode && ($mode !~ m/delete/)) && ($mt->{login_again} ||
2141        ($mt->{requires_login} && !$mt->user))) {
2142        ## If it's a login screen, direct the user to where they were going
2143        ## (query params including mode and all) unless they were logging in,
2144        ## logging out, or deleting something.
2145        my $q = $mt->{query};
2146        if ($mode) {
2147            my @query = map { { name => $_, value => scalar encode_text( $q->param($_) ) }; }
2148                grep { ($_ ne 'username') && ($_ ne 'password') && ($_ ne 'submit') && ($mode eq 'logout' ? ($_ ne '__mode') : 1) } $q->param;
2149            $param->{query_params} = \@query;
2150        }
2151        $param->{login_again} = $mt->{login_again};
2152    }
2153
2154    my $blog = $mt->blog;
2155    $tmpl->context()->stash('blog', $blog) if $blog;
2156
2157    $tmpl->param($param) if $param;
2158
2159    if ($tmpl_file) {
2160        $tmpl_file = File::Basename::basename($tmpl_file);
2161        $tmpl_file =~ s/\.tmpl$//;
2162        $tmpl_file = '.' . $tmpl_file;
2163    }
2164    $mt->run_callbacks('template_param' . $tmpl_file, $mt, $tmpl->param, $tmpl);
2165
2166    my $output = $mt->build_page_in_mem($tmpl);
2167    return unless defined $output;
2168
2169    $mt->run_callbacks('template_output' . $tmpl_file, $mt, \$output, $tmpl->param, $tmpl);
2170    return $output;
2171}
2172
2173sub build_page_in_mem {
2174    my $mt = shift;
2175    my($tmpl, $param) = @_;
2176    $tmpl->param($param) if $param;
2177    my $out = $tmpl->output;
2178    return $mt->error($tmpl->errstr) unless defined $out;
2179    return $mt->translate_templatized($mt->process_mt_template($out));
2180}
2181
2182sub new_ua {
2183    my $class = shift;
2184    my ($opt) = @_;
2185    $opt ||= {};
2186    my $lwp_class = 'LWP::UserAgent';
2187    if ($opt->{paranoid}) {
2188        eval { require LWPx::ParanoidAgent; };
2189        $lwp_class = 'LWPx::ParanoidAgent' unless $@;
2190    }
2191    eval "require $lwp_class;";
2192    return undef if $@;
2193    my $cfg = $class->config;
2194    my $max_size = exists $opt->{max_size} ? $opt->{max_size} : 100_000;
2195    my $timeout = exists $opt->{timeout} ? $opt->{timeout} : $cfg->HTTPTimeout || $cfg->PingTimeout;
2196    my $proxy = exists $opt->{proxy} ? $opt->{proxy} : $cfg->HTTPProxy || $cfg->PingProxy;
2197    my $no_proxy = exists $opt->{no_proxy} ? $opt->{no_proxy} : $cfg->HTTPNoProxy || $cfg->PingNoProxy;
2198    my $agent = $opt->{agent} || 'MovableType/' . $MT::VERSION;
2199    my $interface = exists $opt->{interface} ? $opt->{interface} : $cfg->HTTPInterface || $cfg->PingInterface;
2200
2201    if ( my $localaddr = $interface ) {
2202        @LWP::Protocol::http::EXTRA_SOCK_OPTS = (
2203            LocalAddr => $localaddr,
2204            Reuse     => 1
2205        );
2206    }
2207
2208    my $ua = $lwp_class->new;
2209    $ua->max_size($max_size) if (defined $max_size) && $ua->can('max_size');
2210    $ua->agent( $agent );
2211    $ua->timeout( $timeout ) if defined $timeout;
2212    if ( defined $proxy ) {
2213        $ua->proxy( http => $proxy );
2214        my @domains = split( /,\s*/, $no_proxy ) if $no_proxy;
2215        $ua->no_proxy(@domains) if @domains;
2216    }
2217    return $ua;
2218}
2219
2220sub build_email {
2221    my $class = shift;
2222    my ( $file, $param ) = @_;
2223    my $mt = $class->instance;
2224
2225    # basically, try to load from database
2226    my $blog = $param->{blog} || undef;
2227    my $id = $file;
2228    $id =~ s/(\.tmpl|\.mtml)$//;
2229
2230    require MT::Template;
2231    my @tmpl = MT::Template->load(
2232        {
2233            ( $blog ? ( blog_id => [ $blog->id, 0 ] ) : ( blog_id => 0 ) ),
2234            identifier => $id,
2235            type       => 'email',
2236        }
2237    );
2238    my $tmpl =
2239      @tmpl
2240      ? (
2241        scalar @tmpl > 1
2242        ? ( $tmpl[0]->blog_id ? $tmpl[0] : $tmpl[1] )
2243        : $tmpl[0]
2244      )
2245      : undef;
2246
2247    # try to load from file
2248    unless ($tmpl) {
2249        local $mt->{template_dir} = 'email';
2250        $tmpl = $mt->load_tmpl($file);
2251    }
2252    return unless $tmpl;
2253
2254    my $ctx = $tmpl->context;
2255    $ctx->stash( 'blog_id', $blog->id ) if $blog;
2256    $ctx->stash( 'blog',   delete $param->{'blog'} )   if $param->{'blog'};
2257    $ctx->stash( 'entry',  delete $param->{'entry'} )  if $param->{'entry'};
2258    $ctx->stash( 'author', delete $param->{'author'} ) if $param->{'author'};
2259    $ctx->stash( 'commenter', delete $param->{'commenter'} )
2260      if $param->{'commenter'};
2261    $ctx->stash( 'comment', delete $param->{'comment'} ) if $param->{'comment'};
2262    $ctx->stash( 'category', delete $param->{'category'} )
2263      if $param->{'category'};
2264    $ctx->stash( 'ping', delete $param->{'ping'} ) if $param->{'ping'};
2265
2266    foreach my $p (%$param) {
2267        if ( ref($p) ) {
2268            $tmpl->param( $p, $param->{$p} );
2269        }
2270    }
2271    return $mt->build_page_in_mem( $tmpl, $param );
2272}
2273
2274sub get_next_sched_post_for_user {
2275    my ( $author_id, @further_blog_ids ) = @_;
2276    require MT::Permission;
2277    my @perms = MT::Permission->load( { author_id => $author_id }, {} );
2278    my @blogs = @further_blog_ids;
2279    for my $perm (@perms) {
2280        next
2281          unless ( $perm->can_edit_config
2282            || $perm->can_publish_post
2283            || $perm->can_edit_all_posts );
2284        push @blogs, $perm->blog_id;
2285    }
2286    my $next_sched_utc = undef;
2287    require MT::Entry;
2288    for my $blog_id (@blogs) {
2289        my $blog           = MT::Blog->load($blog_id)
2290            or next;
2291        my $earliest_entry = MT::Entry->load(
2292            {
2293                status  => MT::Entry::FUTURE(),
2294                blog_id => $blog_id
2295            },
2296            { 'sort' => 'created_on' }
2297        );
2298        if ($earliest_entry) {
2299            my $entry_utc =
2300              MT::Util::ts2iso( $blog, $earliest_entry->created_on );
2301            if ( $entry_utc < $next_sched_utc || !defined($next_sched_utc) ) {
2302                $next_sched_utc = $entry_utc;
2303            }
2304        }
2305    }
2306    return $next_sched_utc;
2307}
2308
2309our %Commenter_Auth;
2310
2311sub init_commenter_authenticators {
2312    my $self = shift;
2313    my $auths = $self->registry("commenter_authenticators") || {};
2314    foreach my $auth ( keys %$auths ) {
2315        delete $auths->{$auth}
2316          if exists( $auths->{$auth}->{condition} )
2317          && !( $auths->{$auth}->{condition}->() );
2318    }
2319    %Commenter_Auth = %$auths;
2320    $Commenter_Auth{$_}{key} ||= $_ for keys %Commenter_Auth;
2321}
2322
2323sub commenter_authenticator {
2324    my $self = shift;
2325    my ($key) = @_;
2326    %Commenter_Auth or $self->init_commenter_authenticators();
2327    return $Commenter_Auth{$key};
2328}
2329
2330sub commenter_authenticators {
2331    my $self = shift;
2332    %Commenter_Auth or $self->init_commenter_authenticators();
2333    return values %Commenter_Auth;
2334}
2335
2336sub _commenter_auth_params {
2337    my ( $key, $blog_id, $entry_id, $static ) = @_;
2338    my $params = {
2339        blog_id => $blog_id,
2340        static  => $static,
2341    };
2342    $params->{entry_id} = $entry_id if defined $entry_id;
2343    return $params;
2344}
2345
2346sub _openid_commenter_condition {
2347    eval "require Digest::SHA1;";
2348    return $@ ? 0 : 1;
2349}
2350
2351sub core_commenter_authenticators {
2352    return {
2353        'OpenID' => {
2354            class      => 'MT::Auth::OpenID',
2355            label      => 'OpenID',
2356            login_form => <<OpenID,
2357<form method="post" action="<mt:var name="script_url">">
2358<input type="hidden" name="__mode" value="login_external" />
2359<input type="hidden" name="blog_id" value="<mt:var name="blog_id">" />
2360<input type="hidden" name="entry_id" value="<mt:var name="entry_id">" />
2361<input type="hidden" name="static" value="<mt:var name="static" escape="html">" />
2362<fieldset>
2363<mtapp:setting
2364    id="openid_display"
2365    label="<__trans phrase="OpenID URL">"
2366    hint="<__trans phrase="Sign in using your OpenID identity.">">
2367<input type="hidden" name="key" value="OpenID" />
2368<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%;" />
2369    <p class="hint"><__trans phrase="OpenID is an open and decentralized single sign-on identity system."></p>
2370</mtapp:setting>
2371<img src="<mt:var name="static_uri">images/comment/openid_enabled.png" class="right" />
2372<div class="actions-bar actions-bar-login">
2373    <div class="actions-bar-inner pkg actions">
2374        <button
2375            type="submit"
2376            class="primary-button"
2377            ><__trans phrase="Sign in"></button>
2378    </div>
2379</div>
2380<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>
2381</fieldset>
2382</form>
2383OpenID
2384            login_form_params => \&_commenter_auth_params,
2385            condition         => \&_openid_commenter_condition,
2386            logo              => 'images/comment/signin_openid.png',
2387            logo_small        => 'images/comment/openid_logo.png',
2388        },
2389        'LiveJournal' => {
2390            class      => 'MT::Auth::LiveJournal',
2391            label      => 'LiveJournal',
2392            login_form => <<LiveJournal,
2393<form method="post" action="<mt:var name="script_url">">
2394<input type="hidden" name="__mode" value="login_external" />
2395<input type="hidden" name="blog_id" value="<mt:var name="blog_id">" />
2396<input type="hidden" name="entry_id" value="<mt:var name="entry_id">" />
2397<input type="hidden" name="static" value="<mt:var name="static" escape="html">" />
2398<input type="hidden" name="key" value="LiveJournal" />
2399<fieldset>
2400<mtapp:setting
2401    id="livejournal_display"
2402    label="<__trans phrase="Your LiveJournal Username">"
2403    hint="<__trans phrase="Sign in using your Vox blog URL">">
2404<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%;" />
2405</mtapp:setting>
2406<div class="actions-bar actions-bar-login">
2407    <div class="actions-bar-inner pkg actions">
2408        <button
2409            type="submit"
2410            class="primary-button"
2411            ><__trans phrase="Sign in"></button>
2412    </div>
2413</div>
2414<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>
2415</fieldset>
2416</form>
2417LiveJournal
2418            login_form_params => \&_commenter_auth_params,
2419            condition         => \&_openid_commenter_condition,
2420            logo              => 'images/comment/signin_livejournal.png',
2421            logo_small        => 'images/comment/livejournal_logo.png',
2422        },
2423        'Vox' => {
2424            class      => 'MT::Auth::Vox',
2425            label      => 'Vox',
2426            login_form => <<Vox,
2427<form method="post" action="<mt:var name="script_url">">
2428<input type="hidden" name="__mode" value="login_external" />
2429<input type="hidden" name="blog_id" value="<mt:var name="blog_id">" />
2430<input type="hidden" name="entry_id" value="<mt:var name="entry_id">" />
2431<input type="hidden" name="static" value="<mt:var name="static" escape="html">" />
2432<input type="hidden" name="key" value="Vox" />
2433<fieldset>
2434<mtapp:setting
2435    id="vox_display"
2436    label="<__trans phrase="Your Vox Blog URL">">
2437http:// <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
2438</mtapp:setting>
2439<div class="actions-bar actions-bar-login">
2440    <div class="actions-bar-inner pkg actions">
2441        <button
2442            type="submit"
2443            class="primary-button"
2444            ><__trans phrase="Sign in"></button>
2445    </div>
2446</div>
2447<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>
2448</fieldset>
2449</form>
2450Vox
2451            login_form_params => \&_commenter_auth_params,
2452            condition         => \&_openid_commenter_condition,
2453            logo              => 'images/comment/signin_vox.png',
2454            logo_small        => 'images/comment/vox_logo.png',
2455        },
2456        'TypeKey' => {
2457            class      => 'MT::Auth::TypeKey',
2458            label      => 'TypeKey',
2459            login_form => <<TypeKey,
2460<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>
2461<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>
2462TypeKey
2463            login_form_params => sub {
2464                my ( $key, $blog_id, $entry_id, $static ) = @_;
2465                my $entry = MT::Entry->load($entry_id) if $entry_id;
2466
2467                ## TypeKey URL
2468                require MT::Template::Context;
2469                my $ctx = MT::Template::Context->new;
2470                $ctx->stash( 'blog_id', $blog_id );
2471                my $blog = MT::Blog->load($blog_id);
2472                $ctx->stash( 'blog',  $blog );
2473                $ctx->stash( 'entry', $entry );
2474                my $params = {};
2475                $params->{tk_signin_url} =
2476                  MT::Template::Context::_hdlr_remote_sign_in_link( $ctx,
2477                    { static => $static } );
2478                return $params;
2479            },
2480            logo => 'images/comment/signin_typekey.png',
2481            logo_small        => 'images/comment/typekey_logo.png',
2482        },
2483    };
2484}
2485
2486our %Captcha_Providers;
2487
2488sub captcha_provider {
2489    my $self = shift;
2490    my ($key) = @_;
2491    $self->init_captcha_providers() unless %Captcha_Providers;
2492    return $Captcha_Providers{$key};
2493}
2494
2495sub captcha_providers {
2496    my $self = shift;
2497    $self->init_captcha_providers() unless %Captcha_Providers;
2498    my $def  = delete $Captcha_Providers{'mt_default'};
2499    my @vals = values %Captcha_Providers;
2500    if ( defined($def) && $def->{condition}->() ) {
2501        unshift @vals, $def;
2502    }
2503    @vals;
2504}
2505
2506sub core_captcha_providers {
2507    return {
2508        'mt_default' => {
2509            label     => 'Movable Type default',
2510            class     => 'MT::Util::Captcha',
2511            condition => sub {
2512                require MT::Util::Captcha;
2513                if ( my $error = MT::Util::Captcha->check_availability ) {
2514                    return 0;
2515                }
2516                1;
2517            },
2518        }
2519    };
2520}
2521
2522sub init_captcha_providers {
2523    my $self = shift;
2524    my $providers = $self->registry("captcha_providers") || {};
2525    foreach my $provider ( keys %$providers ) {
2526        delete $providers->{$provider}
2527          if exists( $providers->{$provider}->{condition} )
2528          && !( $providers->{$provider}->{condition}->() );
2529    }
2530    %Captcha_Providers = %$providers;
2531    $Captcha_Providers{$_}{key} ||= $_ for keys %Captcha_Providers;
2532}
2533
2534sub effective_captcha_provider {
2535    my $class = shift;
2536    my ($key) = @_;
2537    return undef unless $key;
2538    my $cp = $class->captcha_provider($key) or return;
2539    if ( exists $cp->{condition} ) {
2540        return undef unless $cp->{condition}->();
2541    }
2542    my $pkg = $cp->{class};
2543    $pkg =~ s/;//g;
2544    eval "require $pkg" or return;
2545    return $cp->{class};
2546}
2547
2548sub handler_to_coderef {
2549    my $pkg = shift;
2550    my ( $name, $delayed ) = @_;
2551
2552    return $name if ref($name) eq 'CODE';
2553    return undef unless defined $name && $name ne '';
2554
2555    my $code;
2556    if ( $name !~ m/->/ ) {
2557
2558        # check for Package::Routine first; if defined, return coderef
2559        no strict 'refs';
2560        $code = \&$name if defined &$name;
2561        return $code if $code;
2562    }
2563
2564    my $component;
2565    if ( $name =~ m!^\$! ) {
2566        if ( $name =~ s/^\$(\w+)::// ) {
2567            $component = $1;
2568        }
2569    }
2570    if ( $name =~ m/^\s*sub\s*\{/s ) {
2571        $code = eval $name or die $@;
2572
2573        if ($component) {
2574            return sub {
2575                my $mt_inst = MT->instance;
2576                local $mt_inst->{component} = $component;
2577                $code->(@_);
2578            };
2579        }
2580        else {
2581            return $code;
2582        }
2583    }
2584
2585    my $hdlr_pkg = $name;
2586    my $method;
2587    if ( $hdlr_pkg =~ s/(->|::)([^:]+)$// ) {    # strip routine name
2588        $method = $2 if $1 eq '->';
2589    }
2590    if ( !defined(&$name) && !$pkg->can( 'AUTOLOAD' ) ) {
2591
2592        # The delayed option will return a coderef that delays the loading
2593        # of the package holding the handler routine.
2594        if ($delayed) {
2595            if ($method) {
2596                return sub {
2597                    eval "# line " . __LINE__ . " " . __FILE__ . "\nrequire $hdlr_pkg;"
2598                      or Carp::confess(
2599                        "failed loading package $hdlr_pkg for routine $name: $@");
2600                    my $mt_inst = MT->instance;
2601                    local $mt_inst->{component} = $component
2602                      if $component;
2603                    return $hdlr_pkg->$method(@_);
2604                };
2605            }
2606            else {
2607                return sub {
2608                    eval "# line " . __LINE__ . " " . __FILE__ . "\nrequire $hdlr_pkg;"
2609                      or Carp::confess(
2610                        "failed loading package $hdlr_pkg for routine $name: $@");
2611                    my $mt_inst = MT->instance;
2612                    local $mt_inst->{component} = $component
2613                      if $component;
2614                    no strict 'refs';
2615                    my $hdlr = \&$name;
2616                    use strict 'refs';
2617                    return $hdlr->(@_);
2618                };
2619            }
2620        }
2621        else {
2622            eval "# line " . __LINE__ . " " . __FILE__ . "\nrequire $hdlr_pkg;"
2623              or Carp::confess(
2624                "failed loading package $hdlr_pkg for routine $name: $@");
2625        }
2626    }
2627    if ($method) {
2628        $code = sub {
2629            my $mt_inst = MT->instance;
2630            local $mt_inst->{component} = $component
2631              if $component;
2632            return $hdlr_pkg->$method(@_);
2633        };
2634    }
2635    else {
2636        if ($component) {
2637            $code = sub {
2638                no strict 'refs';
2639                my $hdlr = (
2640                    defined &$name ? \&$name
2641                    : ( $pkg->can( 'AUTOLOAD' ) ? \&$name
2642                        : undef )
2643                );
2644                use strict 'refs';
2645                if ($hdlr) {
2646                    my $mt_inst = MT->instance;
2647                    local $mt_inst->{component} = $component
2648                      if $component;
2649                    return $hdlr->(@_);
2650                }
2651                return undef;
2652              }
2653        }
2654        else {
2655            no strict 'refs';
2656            $code =
2657              (
2658                defined &$name
2659                ? \&$name
2660                : ( $hdlr_pkg->can( 'AUTOLOAD' ) ? \&$name : undef )
2661              );
2662        }
2663    }
2664    return $code;
2665}
2666
2667sub help_url {
2668    my $pkg = shift;
2669    my ( $append ) = @_;
2670
2671    my $url = $pkg->config->HelpURL;
2672    return $url if defined $url;
2673    $url = $pkg->translate('http://www.movabletype.org/documentation/');
2674    if ( $append ) {
2675        $url .= $append;
2676    }
2677    $url;
2678}
2679
2680sub register_refresh_cache_event {
2681    my $pkg = shift;
2682    my ($callback) = @_;
2683    return unless $callback;
2684
2685    MT->_register_core_callbacks({
2686        "$callback" => \&refresh_cache,
2687    });
2688}
2689
2690sub refresh_cache {
2691    my ($cb, %args) = @_;
2692
2693    require MT::Cache::Negotiate;
2694    my $cache_driver = MT::Cache::Negotiate->new();
2695    return unless $cache_driver;
2696
2697    $cache_driver->flush_all();
2698}
2699
2700sub DESTROY {
2701    # save_config here so not to miss any dirty config change to persist
2702    # particulary for those which does not construct MT::App.
2703    $_[0]->config->save_config();
2704}
2705
27061;
2707
2708__END__
2709
2710=head1 NAME
2711
2712MT - Movable Type
2713
2714=head1 SYNOPSIS
2715
2716    use MT;
2717    my $mt = MT->new;
2718    $mt->rebuild(BlogID => 1)
2719        or die $mt->errstr;
2720
2721=head1 DESCRIPTION
2722
2723The I<MT> class is the main high-level rebuilding/pinging interface in the
2724Movable Type library. It handles all rebuilding operations. It does B<not>
2725handle any of the application functionality--for that, look to I<MT::App> and
2726I<MT::App::CMS>, both of which subclass I<MT> to handle application requests.
2727
2728=head1 PLUGIN APPLICATIONS
2729
2730At any given time, the user of the Movable Type platform is
2731interacting with either the core Movable Type application, or a plugin
2732application (or "sub-application").
2733
2734A plugin application is a plugin with a user interface that inherits
2735functionality from Movable Type, and appears to the user as a
2736component of Movable Type. A plugin application typically has its own
2737templates displaying its own special features; but it inherits some
2738templates from Movable Type, such as the navigation chrome and error
2739pages.
2740
2741=head2 The MT Root and the Application Root
2742
2743To locate assets of the core Movable Type application and any plugin
2744applications, the platform uses two directory paths, C<mt_dir> and
2745C<app_dir>. These paths are returned by the MT class methods with the
2746same names, and some other methods return derivatives of these paths.
2747
2748Conceptually, mt_dir is the root of the Movable Type installation, and
2749app_dir is the root of the "currently running application", which
2750might be Movable Type or a plugin application. It is important to
2751understand the distinction between these two values and what each is
2752used for.
2753
2754The I<mt_dir> is the absolute path to the directory where MT itself is
2755located. Most importantly, the MT configuration file and the CGI scripts that
2756bootstrap an MT request are found here. This directory is also the
2757default base path under which MT's core templates are found (but this
2758can be overridden using the I<TemplatePath> configuration setting).
2759
2760Likewise, the I<app_dir> is the directory where the "current"
2761application's assets are rooted. The platform will search for
2762application templates underneath the I<app_dir>, but this search also
2763searches underneath the I<mt_dir>, allowing the application to make
2764use of core headers, footers, error pages, and possibly other
2765templates.
2766
2767In order for this to be useful, the plugin's templates and
2768code should all be located underneath the same directory. The relative
2769path from the I<app_dir> to the application's templates is
2770configurable. For details on how to indicate the location of your
2771plugin's templates, see L<MT::App>.
2772
2773=head2 Finding the Root Paths
2774
2775When a plugin application initializes its own application class (a
2776subclass of MT::App), the I<mt_dir> should be discovered and passed
2777constructor. This comes either from the C<Directory> parameter or the
2778C<Config> parameter.
2779
2780Since plugins are loaded from a descendent of the MT root directory,
2781the plugin bootstrap code can discover the MT configuration file (and thus
2782the MT root directory) by traversing the filesystem; the absolute path
2783to that file can be passed as the C<Config> parameter to
2784MT::App::new. Working code to do this can be found in the
2785examples/plugins/mirror/mt-mirror.cgi file.
2786
2787The I<app_dir>, on the other hand, always derives from the location of
2788the currently-running program, so it typically does not need to be
2789specified.
2790
2791=head1 USAGE
2792
2793I<MT> has the following interface. On failure, all methods return C<undef>
2794and set the I<errstr> for the object or class (depending on whether the
2795method is an object or class method, respectively); look below at the section
2796L<ERROR HANDLING> for more information.
2797
2798=head2 MT->new( %args )
2799
2800Constructs a new I<MT> instance and returns that object. Returns C<undef>
2801on failure.
2802
2803I<new> will also read your MT configuration file (provided that it can find it--if
2804you find that it can't, take a look at the I<Config> directive, below). It
2805will also initialize the chosen object driver; the default is the C<DBM>
2806object driver.
2807
2808I<%args> can contain:
2809
2810=over 4
2811
2812=item * Config
2813
2814Path to the MT configuration file.
2815
2816If you do not specify a path, I<MT> will try to find your MT configuration file
2817in the current working directory.
2818
2819=item * Directory
2820
2821Path to the MT home directory.
2822
2823If you do not specify a path, I<MT> will try to find the MT directory using
2824the discovered path of the MT configuration file.
2825
2826=back
2827
2828=head2 $mt->init
2829
2830Initializes the Movable Type instance, including registration of basic
2831resources and callbacks. This method also invokes the C<init_config>
2832and C<init_plugins> methods.
2833
2834=head2 MT->instance
2835
2836MT and all it's subclasses are now singleton classes, meaning you can only
2837have one instance per package. MT->instance() returns the active instance.
2838MT->new() is now an alias to instance_of.
2839
2840=head2 $class->instance_of
2841
2842Returns the singleton instance of the MT subclass identified by C<$class>.
2843
2844=head2 $class->construct
2845
2846Constructs a new instance of the MT subclass identified by C<$class>.
2847
2848=head2 MT->set_instance
2849
2850Assigns the active MT instance object. This value is returned when
2851C<MT-E<gt>instance> is invoked.
2852
2853=head2 $mt->find_config($params)
2854
2855Handles the discovery of the MT configuration file. The path and filename
2856for the configuration file is returned as the result. The C<$params>
2857parameter is a reference to the hash of settings passed to the MT
2858constructor.
2859
2860=head2 $mt->init_config($params)
2861
2862Reads the MT configuration settingss from the MT configuration file
2863and settings from database (L<MT::Config>).
2864
2865The C<$params> parameter is a reference to the hash of settings passed to
2866the MT constructor.
2867
2868=head2 $mt->init_plugins
2869
2870Loads any discoverable plugins that are available. This is called from
2871the C<init> method, after the C<init_config> method has loaded the
2872configuration settings.
2873
2874=head2 $mt->init_tasks
2875
2876Registers the standard set of periodic tasks that Movable Type provides
2877and then invokes the C<init_tasks> method for each available plugin.
2878
2879=head2 MT->run_tasks
2880
2881Initializes the tasks, running C<init_tasks> and invokes the task system
2882through L<MT::TaskMgr> to run any registered tasks that are pending
2883execution. See L<MT::TaskMgr> for further documentation.
2884
2885=head2 MT->unplug
2886
2887Removes the global reference to the MT instance.
2888
2889=head2 MT::log( $message ) or $mt->log( $message )
2890
2891Adds an entry to the application's log table. Also writes message to
2892STDERR which is typically routed to the web server's error log.
2893
2894=head2 $mt->server_path, $mt->mt_dir
2895
2896Both of these methods return the physical file path to the directory
2897that is the home of the MT installation. This would be the value of
2898the 'Directory' parameter given in the MT constructor, or would be
2899determined based on the path of the configuration file.
2900
2901=head2 $mt->app_dir
2902
2903Returns the physical file path to the active application directory. This
2904is determined by the directory of the active script.
2905
2906=head2 $mt->config_dir
2907
2908Returns the path to the MT configuration file.
2909
2910=head2 $mt->config([$setting[, $value]])
2911
2912This method is used to get and set configuration settings. When called
2913without any parameters, it returns the active MT::ConfigMgr instance
2914used by the application.
2915
2916Specifying the C<$setting> parameter will return the value for that setting.
2917When passing the C<$value> parameter, this will update the config object,
2918assigning that value for the named C<$setting>.
2919
2920=head2 $mt->user_class
2921
2922Returns the package name for the class used for user authentication.
2923This is typically L<MT::Author>.
2924
2925=head2 $mt->request([$element[,$data]])
2926
2927The request method provides a request-scoped storage object. It is an
2928access interface for the L<MT::Request> package. Calling without any
2929parameters will return the L<MT::Request> instance.
2930
2931When called with the C<$element> parameter, the data stored for that
2932element is returned (or undef, if it didn't exist). When called with
2933the C<$data> parameter, it will store the data into the specified
2934element in the request object.
2935
2936All values placed in the request object are lost at the end of the
2937request. If the running application is not a web-based application,
2938the request object exists for the lifetime of the process and is
2939released when the process ends.
2940
2941See the L<MT::Request> package for more information.
2942
2943=head2 MT->new_ua
2944
2945Returns a new L<LWP::UserAgent> instance that is configured according to the
2946Movable Type configuration settings (specifically C<HTTPInterface>, C<HTTPTimeout>, C<HTTPProxy> and C<HTTPNoProxy>). The agent string is set
2947to "MovableType/(version)" and is also limited to receiving a response of
2948100,000 bytes by default (you can override this by using the 'max_size'
2949method on the returned instance). Using this method is recommended for
2950any HTTP requests issued by Movable Type since it uses the MT configuration
2951settings to prepare the UserAgent object.
2952
2953=head2 $mt->ping( %args )
2954
2955Sends all configured XML-RPC pings as a way of notifying other community
2956sites that your blog has been updated.
2957
2958I<%args> can contain:
2959
2960=over 4
2961
2962=item * Blog
2963
2964An I<MT::Blog> object corresponding to the blog for which you would like to
2965send the pings.
2966
2967Either this or C<BlogID> is required.
2968
2969=item * BlogID
2970
2971The ID of the blog for which you would like to send the pings.
2972
2973Either this or C<Blog> is required.
2974
2975=back
2976
2977=head2 $mt->ping_and_save( %args )
2978
2979Handles the task of issuing any pending ping operations for a given
2980entry and then saving that entry back to the database.
2981
2982The I<%args> hash should contain an element named C<Entry> that is a
2983reference to a L<MT::Entry> object.
2984
2985=head2 $mt->needs_ping(%param)
2986
2987Returns a list of URLs that have not been pinged for a given entry. Named
2988parameters for this method are:
2989
2990=over 4
2991
2992=item Entry
2993
2994The L<MT::Entry> object to examine.
2995
2996=item Blog
2997
2998The L<MT::Blog> object that is the parent of the entry given.
2999
3000=back
3001
3002The return value is an array reference of URLs that have not been pinged
3003for the given entry.
3004
3005An empty list is returned for entries that have a non 'RELEASE' status.
3006
3007=head2 $mt->update_ping_list($blog)
3008
3009Returns a list of URLs for ping services that have been configured to
3010be notified when posting new entries.
3011
3012=head2 $mt->set_language($tag)
3013
3014Loads the localization plugin for the language specified by I<$tag>, which
3015should be a valid and supported language tag--see I<supported_languages> to
3016obtain a list of supported languages.
3017
3018The language is set on a global level, and affects error messages and all
3019text in the administration system.
3020
3021This method can be called as either a class method or an object method; in
3022other words,
3023
3024    MT->set_language($tag)
3025
3026will also work. However, the setting will still be global--it will not be
3027specified to the I<$mt> object.
3028
3029The default setting--set when I<MT::new> is called--is U.S. English. If a
3030I<DefaultLanguage> is set in the MT configuration file, the default is then
3031set to that language.
3032
3033=head2 MT->translate($str[, $param, ...])
3034
3035Translates I<$str> into the currently-set language (set by I<set_language>),
3036and returns the translated string. Any parameters following I<$str> are
3037passed through to the C<maketext> method of the active localization module.
3038
3039=head2 MT->translate_templatized($str)
3040
3041Translates a string that has embedded E<lt>MT_TRANSE<gt> tags. These
3042tags identify the portions of the string that require localization.
3043Each tag is processed separately and passed through the MT->translate
3044method. Examples (used in your application's HTML::Template templates):
3045
3046    <p><MT_TRANS phrase="Hello, world"></p>
3047
3048and
3049
3050    <p><MT_TRANS phrase="Hello, [_1]" params="<TMPL_VAR NAME=NAME>"></p>
3051
3052=head2 $mt->trans_error( $str[, $arg1, $arg2] )
3053
3054Translates I<$str> into the currently-set language (set by I<set_language>),
3055and assigns it as the active error for the MT instance. It returns undef,
3056which is the usual return value upon generating an error in the application.
3057So when an error occurs, the typical return result would be:
3058
3059    if ($@) {
3060        return $app->trans_error("An error occurred: [_1]", $@);
3061    }
3062
3063The optional I<$arg1> (and so forth) parameters are passed as parameters to
3064any parameterized error message.
3065
3066=head2 $mt->current_language
3067
3068Returns the language tag for the currently-set language.
3069
3070=head2 MT->supported_languages
3071
3072Returns a reference to an associative array mapping language tags to their
3073proper names. For example:
3074
3075    use MT;
3076    my $langs = MT->supported_languages;
3077    print map { $_ . " => " . $langs->{$_} . "\n" } keys %$langs;
3078
3079=head2 MT->language_handle
3080
3081Returns the active MT::L10N language instance for the active language.
3082
3083=head2 MT->add_plugin($plugin)
3084
3085Adds the plugin described by $plugin to the list of plugins displayed
3086on the welcome page. The argument should be an object of the
3087I<MT::Plugin> class.
3088
3089=head2 MT->all_text_filters
3090
3091Returns a reference to a hash containing the registry of text filters.
3092
3093=head2 MT->apply_text_filters($str, \@filters)
3094
3095Applies the set of filters I<\@filters> to the string I<$str> and returns
3096the result (the filtered string).
3097
3098I<\@filters> should be a reference to an array of filter keynames--these
3099are the short names passed in as the first argument to I<add_text_filter>.
3100I<$str> should be a scalar string to be filtered.
3101
3102If one of the filters listed in I<\@filters> is not found in the list of
3103registered filters (that is, filters added through I<add_text_filter>),
3104it will be skipped silently. Filters are executed in the order in which they
3105appear in I<\@filters>.
3106
3107As it turns out, the I<MT::Entry::text_filters> method returns a reference
3108to the list of text filters to be used for that entry. So, for example, to
3109use this method to apply filters to the main entry text for an entry
3110I<$entry>, you would use
3111
3112    my $out = MT->apply_text_filters($entry->text, $entry->text_filters);
3113
3114=head2 MT->add_callback($meth, $priority, $plugin, $code)
3115
3116Registers a new callback handler for a particular registered callback.
3117
3118The first parameter is the name of the callback method. The second
3119parameter is a priority (a number in the range of 1-10) which will control
3120the order that the handler is executed in relation to other handlers. If
3121two handlers register with the same priority, they will be executed in
3122the order that they registered. The third parameter is a C<MT::Plugin> object
3123reference that is associated with the handler (this parameter is optional).
3124The fourth parameter is a code reference that is invoked to handle the
3125callback. For example:
3126
3127    MT->add_callback('BuildFile', 1, undef, \&rebuild_file_hdlr);
3128
3129The code reference should expect to receive an object of type
3130L<MT::Callback> as its first argument. This object is used to
3131communicate errors to the caller:
3132
3133    sub rebuild_file_hdlr {
3134        my ($cb, ...) = @_;
3135        if (something bad happens) {
3136            return $cb->error("Something bad happened!");
3137        }
3138    }
3139
3140Other parameters to the callback function depend on the callback point.
3141
3142The treatment of the error string depends on the callback point.
3143Typically, either it is ignored or the user's action fails and the
3144error message is displayed.
3145
3146The value returned from this method is the new L<MT::Callback> object.
3147
3148=head2 MT->remove_callback($callback)
3149
3150Removes a callback that was previously registered.
3151
3152=head2 MT->register_callbacks([...])
3153
3154Registers several callbacks simultaneously. Each element in the array
3155parameter given should be a hashref containing these elements: C<name>,
3156C<priority>, C<plugin> and C<code>.
3157
3158=head2 MT->run_callbacks($meth[, $arg1, $arg2, ...])
3159
3160Invokes a particular callback, running any associated callback handlers.
3161
3162The first parameter is the name of the callback to execute. This is one
3163of the global callback methods (see L<Callbacks> section) or can be
3164a class-specific method that includes the package name associated with
3165the callback.
3166
3167The remaining arguments are passed through to any callback handlers that
3168are invoked.
3169
3170For "Filter"-type callbacks, this routine will return a 0 if any of the
3171handlers return a false result. If all handlers return a true result,
3172a value of 1 is returned.
3173
3174Example:
3175
3176    MT->run_callbacks('MyClass::frobnitzes', \@whirlygigs);
3177
3178Which would execute any handlers that registered in this fashion:
3179
3180    MT->add_callback('MyClass::frobnitzes', 4, $plugin, \&frobnitz_hdlr);
3181
3182=head2 MT->run_callback($cb[, $arg1, $arg2, ...])
3183
3184An internal routine used by C<run_callbacks> to invoke a single
3185L<MT::Callback>.
3186
3187=head2 callback_error($str)
3188
3189This routine is used internally by C<MT::Callback> to set any error response
3190that comes from invoking a callback.
3191
3192=head2 callback_errstr
3193
3194This internal routine returns the error response stored using the
3195C<callback_error> routine.
3196
3197=head2 MT->product_code
3198
3199The product code identifying the Movable Type product that is installed.
3200This is either 'MTE' for Movable Type Enterprise or 'MT' for the
3201non-Enterprise product.
3202
3203=head2 MT->product_name
3204
3205The name of the Movable Type product that is installed. This is either
3206'Movable Type Enterprise' or 'Movable Type Publishing Platform'.
3207
3208=head2 MT->product_version
3209
3210The version number of the product. This is different from the C<version_id>
3211and C<version_number> methods as they report the API version information.
3212
3213=head2 MT->version_id
3214
3215Returns the API version of MT (including any beta/alpha designations).
3216
3217=head2 MT->version_number
3218
3219Returns the numeric API version of MT (without any beta/alpha designations).
3220For example, if I<version_id> returned C<2.5b1>, I<version_number> would
3221return C<2.5>.
3222
3223=head2 MT->schema_version
3224
3225Returns the version of the MT database schema.
3226
3227=head2 MT->version_slug
3228
3229Returns a string of text that is appended to emails sent through the
3230C<build_email> method.
3231
3232=head2 $mt->publisher
3233
3234Returns the L<MT::WeblogPublisher> object that is used for managing the
3235MT publishing process. See L<MT::WeblogPublisher> for more information.
3236
3237=head2 $mt->rebuild
3238
3239An alias to L<MT::WeblogPublisher::rebuild>. See L<MT::WeblogPublisher>
3240for documentation of this method.
3241
3242=head2 $mt->rebuild_entry
3243
3244An alias to L<MT::WeblogPublisher::rebuild_entry>. See L<MT::WeblogPublisher>
3245for documentation of this method.
3246
3247=head2 $mt->rebuild_indexes
3248
3249An alias to L<MT::WeblogPublisher::rebuild_indexes>. See
3250L<MT::WeblogPublisher> for documentation of this method.
3251
3252=head2 $mt->build_email($file, $param)
3253
3254Loads a template from the application's 'email' template directory and
3255processes it as a HTML::Template. The C<$param> argument is a hash reference
3256of parameter data for the template. The return value is the output of the
3257template.
3258
3259=head2 MT::get_next_sched_post_for_user($author_id, @blog_ids)
3260
3261This is an internal routine used by L<MT::XMLRPCServer> and the
3262getNextScheduled XMLRPC method to determine the timestamp for the next
3263entry that is scheduled for publishing. The return value is the timestamp
3264in UTC time in the format "YYYY-MM-DDTHH:MM:SSZ".
3265
3266=head1 ERROR HANDLING
3267
3268On an error, all of the above methods return C<undef>, and the error message
3269can be obtained by calling the method I<errstr> on the class or the object
3270(depending on whether the method called was a class method or an instance
3271method).
3272
3273For example, called on a class name:
3274
3275    my $mt = MT->new or die MT->errstr;
3276
3277Or, called on an object:
3278
3279    $mt->rebuild(BlogID => $blog_id)
3280        or die $mt->errstr;
3281
3282=head1 DEBUGGING
3283
3284MT has a package variable C<$MT::DebugMode> which is assigned through
3285your MT configuration file (DebugMode setting). If this is set to
3286any non-zero value, MT applications will display any C<warn>'d
3287statements to a panel that is displayed within the app.
3288
3289The DebugMode is a bit-wise setting and offers the following options:
3290
3291    1 - Display debug messages
3292    2 - Display a stack trace for messages captured
3293    4 - Lists queries issued by Data::ObjectDriver
3294    8 - Reports on MT templates that take more than 1/4 second to build*
3295    128 - Outputs app-level request/response information to STDERR.
3296
3297These can be combined, so if you want to display queries and debug messages,
3298use a DebugMode of 5 for instance.
3299
3300You may also use the local statement to temporarily apply a particular bit,
3301if you want to scope the debug messages you receive to a block of code:
3302
3303    local $MT::DebugMode |= 4;  # show me the queries for the following
3304    my $obj = MT::Entry->load({....});
3305
3306*DebugMode bit 8 actually outputs it's messages to STDERR (which typically
3307is sent to your web server's error log).
3308
3309=head1 CALLBACKS
3310
3311Movable Type has a variety of hook points at which a plugin can attach
3312a callback.
3313
3314In each case, the first parameter is an L<MT::Callback> object which
3315can be used to pass error information back to the caller.
3316
3317The app-level callbacks related to rebuilding are documented
3318in L<MT::WeblogPublisher>. The specific apps document the callbacks
3319which they invoke.
3320
3321=head2 NewUserProvisioning($cb, $user)
3322
3323This callback is invoked when a user is being added to Movable Type.
3324Movable Type itself registers for this callback (with a priority of 5)
3325to provision the user with a new weblog if the system has been configured
3326to do so.
3327
3328=head2 post_init($cb, \%param)
3329
3330This callback is invoked when MT is initialized and ready to run.
3331This callback is invoked after MT initialized addons, plugins, schema
3332and permissions.  The arguments passed to initialize MT is passed
3333through to the callback.
3334
3335=head1 LICENSE
3336
3337The license that applies is the one you agreed to when downloading
3338Movable Type.
3339
3340=head1 AUTHOR & COPYRIGHT
3341
3342Except where otherwise noted, MT is Copyright 2001-2008 Six Apart.
3343All rights reserved.
3344
3345=cut
Note: See TracBrowser for help on using the browser.