root/branches/release-35/lib/MT.pm.pre @ 1927

Revision 1927, 105.7 kB (checked in by mpaschal, 20 months ago)

Land the new implementation of metadata based on narrow tables
BugzID: 68749
  • 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    my $log_file;
918
919    # Log filename calcluation; changes daily, so we don't cache this
920    require File::Spec;
921    my $dir = File::Spec->catdir( MT->instance->static_file_path,
922        'support', 'logs');
923    if (! -d $dir) {
924        require File::Path;
925        eval { File::Path::mkpath([$dir], 0, 0777) };
926        if ($@) {
927            $log_file = 0;
928            return;
929        }
930    }
931    my @time = localtime(time);
932    my $file = sprintf("pl-%04d%02d%02d.log", $time[5] + 1900, $time[4]+1, $time[3]);
933    $log_file = File::Spec->catfile( $dir, $file );
934
935    my $first_write = ! -f $log_file;
936
937    local *PERFLOG;
938    open PERFLOG, ">>$log_file";
939    require Fcntl;
940    flock(PERFLOG, Fcntl::LOCK_EX());
941
942    if ($first_write) {
943        require Config;
944        my ($osname, $osvers) = ($Config::Config{osname}, $Config::Config{osvers});
945        print PERFLOG "# Operating System: $osname/$osvers\n";
946        print PERFLOG "# Platform: $^O\n";
947        my $ver = ref($^V) eq 'version' ? $^V->normal : ( $^V ? join('.', unpack 'C*', $^V) : $] );
948        print PERFLOG "# Perl Version: $ver\n";
949        print PERFLOG "# Web Server: $ENV{SERVER_SOFTWARE}\n";
950        require MT::Object;
951        my $driver = MT::Object->driver;
952        if ($driver) {
953            my $dbh = $driver->r_handle;
954            if ($dbh) {
955                my $dbname = $dbh->get_info( 17 ); # SQL_DBMS_NAME
956                my $dbver = $dbh->get_info( 18 ); # SQL_DBMS_VER
957                if ($dbname && $dbver) {
958                    print PERFLOG "# Database: $dbname/$dbver\n";
959                }
960            }
961        }
962        my ($drname, $drh) = each %DBI::installed_drh;
963        print PERFLOG "# Database Library: DBI/" . $DBI::VERSION . "; DBD/" . $drh->{Version} . "\n";
964        if ($ENV{MOD_PERL}) {
965            print PERFLOG "# App Mode: mod_perl\n";
966        }
967        elsif ($ENV{FAST_CGI}) {
968            print PERFLOG "# App Mode: FastCGI\n";
969        }
970        else {
971            print PERFLOG "# App Mode: CGI\n";
972        }
973    }
974
975    if ($memory) {
976        print PERFLOG $timer->dump_line("mem_start=$memory_start", "mem_end=$memory");
977    } else {
978        print PERFLOG $timer->dump_line();
979    }
980
981    close PERFLOG;
982}
983}
984
985sub get_timer {
986    my $mt = shift;
987    $mt = MT->instance unless ref $mt;
988    my $timer = $mt->request('timer');
989    unless (defined $timer) {
990        if (MT->config('PerformanceLogging')) {
991            my $uri;
992            if ($mt->isa('MT::App')) {
993                $uri = $mt->uri( args => { $mt->param_hash } );
994            }
995            require MT::Util::ReqTimer;
996            $timer = MT::Util::ReqTimer->new( $uri );
997        } else {
998            $timer = 0;
999        }
1000        $mt->request('timer', $timer);
1001    }
1002    return $timer;
1003}
1004
1005sub time_this {
1006    my $mt = shift;
1007    my ($str, $code) = @_;
1008    my $timer = $mt->get_timer();
1009    my $ret;
1010    if ($timer) {
1011        $timer->pause_partial();
1012        $ret = $code->();
1013        $timer->mark($str);
1014    } else {
1015        $ret = $code->();
1016    }
1017    return $ret;
1018}
1019
1020sub init_config_from_db {
1021    my $mt = shift;
1022    my ($param) = @_;
1023    my $cfg = $mt->config;
1024    $cfg->read_config_db();
1025
1026    # Tell any instantiated drivers to reconfigure themselves as necessary
1027    MT::ObjectDriverFactory->configure;
1028
1029    1;
1030}
1031
1032sub bootstrap {
1033    my $pkg = shift;
1034    $pkg->init_paths() or return;
1035    $pkg->init_core()  or return;
1036}
1037
1038sub init_paths {
1039    my $mt = shift;
1040    my ($param) = @_;
1041
1042    # determine MT directory
1043    my ($orig_dir);
1044    require File::Spec;
1045    if ( !( $MT_DIR = $ENV{MT_HOME} ) ) {
1046        if ( $0 =~ m!(.*([/\\]))! ) {
1047            $orig_dir = $MT_DIR = $1;
1048            my $slash = $2;
1049            $MT_DIR =~ s!(?:[/\\]|^)(?:plugins[/\\].*|tools[/\\])$!$slash!;
1050            $MT_DIR = '' if ( $MT_DIR =~ m!^\.?[\\/]$! );
1051        }
1052        else {
1053
1054            # MT_DIR/lib/MT.pm -> MT_DIR/lib -> MT_DIR
1055            $MT_DIR = dirname( dirname( File::Spec->rel2abs(__FILE__) ) );
1056        }
1057        unless ($MT_DIR) {
1058            $orig_dir = $MT_DIR = $ENV{PWD} || '.';
1059            $MT_DIR =~ s!(?:[/\\]|^)(?:plugins[/\\].*|tools[/\\]?)$!!;
1060        }
1061        $ENV{MT_HOME} = $MT_DIR;
1062    }
1063    unshift @INC, File::Spec->catdir( $MT_DIR,   'extlib' );
1064    unshift @INC, File::Spec->catdir( $orig_dir, 'lib' )
1065      if $orig_dir && ( $orig_dir ne $MT_DIR );
1066
1067    $mt->set_language('__BUILD_LANGUAGE__');
1068
1069    if ( my $cfg_file = $mt->find_config($param) ) {
1070        $cfg_file = File::Spec->rel2abs($cfg_file);
1071        $CFG_FILE = $cfg_file;
1072    }
1073    else {
1074        return $mt->trans_error(
1075"Missing configuration file. Maybe you forgot to move mt-config.cgi-original to mt-config.cgi?"
1076        ) if ref($mt);
1077    }
1078
1079    # store the mt_dir (home) as an absolute path; fallback to the config
1080    # directory if it isn't set.
1081    $MT_DIR ||=
1082      $param->{directory}
1083      ? File::Spec->rel2abs( $param->{directory} )
1084      : $CFG_DIR;
1085    $MT_DIR ||= dirname($0);
1086
1087    # also make note of the active application path; this is derived by
1088    # checking the PWD environment variable, the dirname of $0,
1089    # the directory of SCRIPT_FILENAME and lastly, falls back to mt_dir
1090    $APP_DIR = $ENV{PWD} || "";
1091    $APP_DIR = dirname($0)
1092      if !$APP_DIR || !File::Spec->file_name_is_absolute($APP_DIR);
1093    $APP_DIR = dirname( $ENV{SCRIPT_FILENAME} )
1094      if $ENV{SCRIPT_FILENAME}
1095      && ( !$APP_DIR || ( !File::Spec->file_name_is_absolute($APP_DIR) ) );
1096    $APP_DIR ||= $MT_DIR;
1097    $APP_DIR = File::Spec->rel2abs($APP_DIR);
1098
1099    return 1;
1100}
1101
1102sub init_core {
1103    my $mt = shift;
1104    return if exists $Components{'core'};
1105    require MT::Core;
1106    my $c = MT::Core->new( { id => 'core', path => $MT_DIR } )
1107      or die MT::Core->errstr;
1108    $Components{'core'} = $c;
1109
1110    # Additional locale-specific defaults
1111    my $defaults = $c->{registry}{config_settings};
1112    $defaults->{DefaultLanguage}{default} = '__BUILD_LANGUAGE__';
1113    $defaults->{NewsboxURL}{default} = '__NEWSBOX_URL__';
1114    $defaults->{LearningNewsURL}{default} = '__LEARNINGNEWS_URL__';
1115    $defaults->{SupportURL}{default} = '__SUPPORT_URL__';
1116    $defaults->{NewsURL}{default} = '__NEWS_URL__';
1117    #$defaults->{HelpURL}{default} = '__HELP_URL__';
1118    $defaults->{DefaultTimezone}{default} = '__DEFAULT_TIMEZONE__';
1119    $defaults->{TimeOffset}{default} = '__DEFAULT_TIMEZONE__';
1120    $defaults->{MailEncoding}{default} = '__MAIL_ENCODING__';
1121    $defaults->{ExportEncoding}{default} = '__EXPORT_ENCODING__';
1122    $defaults->{LogExportEncoding}{default} = '__LOG_EXPORT_ENCODING__';
1123    $defaults->{CategoryNameNodash}{default} = '__CATEGORY_NAME_NODASH__';
1124    $defaults->{PublishCharset}{default} = '__PUBLISH_CHARSET__';
1125
1126    push @Components, $c;
1127    return 1;
1128}
1129
1130sub init {
1131    my $mt    = shift;
1132    my %param = @_;
1133
1134    $mt->bootstrap() unless $MT_DIR;
1135    $mt->{mt_dir}     = $MT_DIR;
1136    $mt->{config_dir} = $CFG_DIR;
1137    $mt->{app_dir}    = $APP_DIR;
1138
1139    $mt->init_callbacks();
1140
1141    ## Initialize the language to the default in case any errors occur in
1142    ## the rest of the initialization process.
1143    $mt->init_config( \%param ) or return;
1144    $mt->init_addons(@_)       or return;
1145    $mt->init_config_from_db( \%param ) or return;
1146    $mt->init_plugins(@_)       or return;
1147    $plugins_installed = 1;
1148    $mt->init_schema();
1149    $mt->init_permissions();
1150
1151    # Load MT::Log so constants are available
1152    require MT::Log;
1153
1154    return $mt;
1155}
1156
1157sub init_callbacks {
1158    my $mt = shift;
1159    MT->_register_core_callbacks({
1160        'build_file_filter' => sub { MT->publisher->queue_build_file_filter(@_) },
1161        'cms_upload_file' => \&core_upload_file_to_sync,
1162        'api_upload_file' => \&core_upload_file_to_sync,
1163    });
1164}
1165
1166sub core_upload_file_to_sync {
1167    my ($cb, %args) = @_;
1168    MT->upload_file_to_sync(%args);
1169}
1170
1171sub upload_file_to_sync {
1172    my $class = shift;
1173    my (%args) = @_;
1174
1175    # no need to do this unless we're syncing stuff.
1176    return unless MT->config('SyncTarget');
1177
1178    my $url = $args{url};
1179    my $file = $args{file};
1180    return unless -f $file;
1181
1182    my $blog = $args{blog};
1183    my $blog_id = $blog->id;
1184    return unless $blog->publish_queue;
1185
1186    require MT::FileInfo;
1187    my $base_url = $url;
1188    $base_url =~ s!^https?://[^/]+!!;
1189    my $fi = MT::FileInfo->load({ blog_id => $blog_id, url => $base_url });
1190    if (!$fi) {
1191        $fi = new MT::FileInfo;
1192        $fi->blog_id($blog_id);
1193        $fi->url($base_url);
1194        $fi->file_path($file);
1195    } else {
1196        $fi->file_path($file);
1197    }
1198    $fi->save;
1199
1200    require MT::TheSchwartz;
1201    require TheSchwartz::Job;
1202    my $job = TheSchwartz::Job->new();
1203    $job->funcname('MT::Worker::Sync');
1204    $job->uniqkey( $fi->id );
1205    $job->coalesce( ( $fi->blog_id || 0 ) . ':' . $$ . ':' . ( time - ( time % 10 ) ) );
1206    MT::TheSchwartz->insert($job);
1207}
1208
1209sub init_addons {
1210    my $mt = shift;
1211    my $cfg = $mt->config;
1212    my @PluginPaths;
1213
1214    unshift @PluginPaths, File::Spec->catdir( $MT_DIR, 'addons' );
1215    return $mt->_init_plugins_core({}, 1, \@PluginPaths);
1216}
1217
1218sub init_plugins {
1219    my $mt = shift;
1220
1221    # Load compatibility module for prior version
1222    # This should always be MT::Compat::v(MAJOR_RELEASE_VERSION - 1).
1223    require MT::Compat::v3;
1224
1225    require MT::Plugin;
1226    my $cfg          = $mt->config;
1227    my $use_plugins  = $cfg->UsePlugins;
1228    my @PluginPaths  = $cfg->PluginPath;
1229    my $PluginSwitch = $cfg->PluginSwitch || {};
1230    return $mt->_init_plugins_core($PluginSwitch, $use_plugins, \@PluginPaths);
1231}
1232
1233sub _init_plugins_core {
1234    my $mt = shift;
1235    my ($PluginSwitch, $use_plugins, $PluginPaths) = @_;
1236
1237    my $timer;
1238    if ($mt->config->PerformanceLogging) {
1239        $timer = $mt->get_timer();
1240    }
1241
1242    foreach my $PluginPath (@$PluginPaths) {
1243        my $plugin_lastdir = $PluginPath;
1244        $plugin_lastdir =~ s![\\/]$!!;
1245        $plugin_lastdir =~ s!.*[\\/]!!;
1246        local *DH;
1247        if ( opendir DH, $PluginPath ) {
1248            my @p = readdir DH;
1249          PLUGIN:
1250            for my $plugin (@p) {
1251                next if ( $plugin =~ /^\.\.?$/ || $plugin =~ /~$/ );
1252
1253                my $load_plugin = sub {
1254                    my ( $plugin, $sig ) = @_;
1255                    die "Bad plugin filename '$plugin'"
1256                      if ( $plugin !~ /^([-\\\/\@\:\w\.\s~]+)$/ );
1257                    local $plugin_sig      = $sig;
1258                    local $plugin_registry = {};
1259                    $plugin = $1;
1260                    if (
1261                        !$use_plugins
1262                        || ( exists $PluginSwitch->{$plugin_sig}
1263                            && !$PluginSwitch->{$plugin_sig} )
1264                      )
1265                    {
1266                        $Plugins{$plugin_sig}{full_path} = $plugin_full_path;
1267                        $Plugins{$plugin_sig}{enabled}   = 0;
1268                        return 0;
1269                    }
1270                    return 0 if exists $Plugins{$plugin_sig};
1271                    $Plugins{$plugin_sig}{full_path} = $plugin_full_path;
1272                    $timer->pause_partial if $timer;
1273                    eval "# line " . __LINE__ . " " . __FILE__ . "\nrequire '$plugin';";
1274                    $timer->mark("Loaded plugin " . $sig) if $timer;
1275                    if ($@) {
1276                        $Plugins{$plugin_sig}{error} = $@;
1277                        # Issue MT log within another eval block in the
1278                        # event that the plugin error is happening before
1279                        # the database has been initialized...
1280                        eval {
1281                            # line __LINE__ __FILE__
1282                            require MT::Log;
1283                            $mt->log(
1284                                {
1285                                    message => $mt->translate(
1286                                        "Plugin error: [_1] [_2]", $plugin,
1287                                        $Plugins{$plugin_sig}{error}
1288                                    ),
1289                                    class => 'system',
1290                                    level => MT::Log::ERROR()
1291                                }
1292                            );
1293                        };
1294                        return 0;
1295                    }
1296                    else {
1297                        if ( my $obj = $Plugins{$plugin_sig}{object} ) {
1298                            $obj->init_callbacks();
1299                        }
1300                        else {
1301
1302                            # A plugin did not register itself, so
1303                            # create a dummy plugin object which will
1304                            # cause it to show up in the plugin listing
1305                            # by it's filename.
1306                            MT->add_plugin( {} );
1307                        }
1308                    }
1309                    $Plugins{$plugin_sig}{enabled} = 1;
1310                    return 1;
1311                };
1312                $plugin_full_path = File::Spec->catfile( $PluginPath, $plugin );
1313                if ( -f $plugin_full_path ) {
1314                    $plugin_envelope = $plugin_lastdir;
1315                    $load_plugin->( $plugin_full_path, $plugin )
1316                      if $plugin_full_path =~ /\.pl$/;
1317                }
1318                else {
1319                    my $plugin_dir = $plugin;
1320                    $plugin_envelope = "$plugin_lastdir/" . $plugin;
1321
1322                    # handle config.yaml
1323                    my $yaml =
1324                      File::Spec->catdir( $plugin_full_path, 'config.yaml' );
1325                    my $libdir;
1326                    ( unshift @INC, $libdir )
1327                      if -d ( $libdir =
1328                          File::Spec->catdir( $plugin_full_path, 'lib' ) );
1329                    if ( -f $yaml ) {
1330                        my $pclass =
1331                          $plugin_dir =~ m/\.pack$/
1332                          ? 'MT::Component'
1333                          : 'MT::Plugin';
1334
1335                        # Don't process disabled plugin config.yaml files.
1336                        if (
1337                            $pclass eq 'MT::Plugin'
1338                            && (
1339                                !$use_plugins
1340                                || ( exists $PluginSwitch->{$plugin_dir}
1341                                    && !$PluginSwitch->{$plugin_dir} )
1342                            )
1343                          )
1344                        {
1345                            $Plugins{$plugin_dir}{full_path} =
1346                              $plugin_full_path;
1347                            $Plugins{$plugin_dir}{enabled} = 0;
1348                            next;
1349                        }
1350                        my $id = lc $plugin_dir;
1351                        $id =~ s/\.\w+$//;
1352                        my $p = $pclass->new(
1353                            {
1354                                id       => $id,
1355                                path     => $plugin_full_path,
1356                                envelope => $plugin_envelope
1357                            }
1358                        );
1359
1360                        # rebless? based on config?
1361                        local $plugin_sig = $plugin_dir;
1362                        MT->add_plugin($p);
1363                        $p->init_callbacks()
1364                            if $pclass eq 'MT::Plugin';
1365                        next;
1366                    }
1367
1368                    opendir SUBDIR, $plugin_full_path;
1369                    my @plugins = readdir SUBDIR;
1370                    closedir SUBDIR;
1371                    for my $plugin (@plugins) {
1372                        next if $plugin !~ /\.pl$/;
1373                        my $plugin_file =
1374                          File::Spec->catfile( $plugin_full_path, $plugin );
1375                        if ( -f $plugin_file ) {
1376                            $load_plugin->(
1377                                $plugin_file, $plugin_dir . '/' . $plugin
1378                            );
1379                        }
1380                    }
1381                }
1382            }
1383            closedir DH;
1384        }
1385    }
1386
1387    # Reset the Text_filters hash in case it was preloaded by plugins by
1388    # calling all_text_filters (Markdown in particular does this).
1389    # Upon calling all_text_filters again, it will be properly loaded by
1390    # querying the registry.
1391    %Text_filters = ();
1392
1393    1;
1394}
1395
1396my %addons;
1397
1398sub find_addons {
1399    my $mt = shift;
1400    my ($type) = @_;
1401
1402    unless (%addons) {
1403        my $addon_path = File::Spec->catdir( $MT_DIR, 'addons' );
1404        local *DH;
1405        if ( opendir DH, $addon_path ) {
1406            my @p = readdir DH;
1407            foreach my $p (@p) {
1408                next if $p eq '.' || $p eq '..';
1409                my $full_path = File::Spec->catdir( $addon_path, $p );
1410                if ( -d $full_path ) {
1411                    if ( $p =~ m/^(.+)\.(\w+)$/ ) {
1412                        my $label = $1;
1413                        my $id    = lc $1;
1414                        my $type  = $2;
1415                        if ( $type eq 'pack' ) {
1416                            $label .= ' Pack';
1417                        }
1418                        elsif ( $type eq 'theme' ) {
1419                            $label .= ' Theme';
1420                        }
1421                        elsif ( $type eq 'plugin' ) {
1422                            $label .= ' Plugin';
1423                        }
1424                        push @{ $addons{$type} },
1425                          {
1426                            label    => $label,
1427                            id       => $id,
1428                            envelope => 'addons/' . $p . '/',
1429                            path     => $full_path,
1430                          };
1431                    }
1432                }
1433            }
1434        }
1435    }
1436    if ($type) {
1437        my $addons = $addons{$type} ||= [];
1438        return $addons;
1439    }
1440    return 1;
1441}
1442
1443*mt_dir = \&server_path;
1444sub server_path { $_[0]->{mt_dir} }
1445sub app_dir     { $_[0]->{app_dir} }
1446sub config_dir  { $_[0]->{config_dir} }
1447
1448sub component {
1449    my $mt = shift;
1450    my ($id) = @_;
1451    return $Components{ lc $id };
1452}
1453
1454sub publisher {
1455    my $mt = shift;
1456    $mt = $mt->instance unless ref $mt;
1457    unless ( $mt->{WeblogPublisher} ) {
1458        require MT::WeblogPublisher;
1459        $mt->{WeblogPublisher} = new MT::WeblogPublisher();
1460    }
1461    $mt->{WeblogPublisher};
1462}
1463
1464sub rebuild {
1465    my $mt = shift;
1466    $mt->publisher->rebuild(@_)
1467      or return $mt->error( $mt->publisher->errstr );
1468}
1469
1470sub rebuild_entry {
1471    my $mt = shift;
1472    $mt->publisher->rebuild_entry(@_)
1473      or return $mt->error( $mt->publisher->errstr );
1474}
1475
1476sub rebuild_indexes {
1477    my $mt = shift;
1478    $mt->publisher->rebuild_indexes(@_)
1479      or return $mt->error( $mt->publisher->errstr );
1480}
1481
1482sub rebuild_archives {
1483    my $mt = shift;
1484    $mt->publisher->rebuild_archives(@_)
1485      or return $mt->error( $mt->publisher->errstr );
1486}
1487
1488sub ping {
1489    my $mt    = shift;
1490    my %param = @_;
1491    my $blog;
1492    require MT::Entry;
1493    require MT::Util;
1494    unless ( $blog = $param{Blog} ) {
1495        my $blog_id = $param{BlogID};
1496        $blog = MT::Blog->load($blog_id)
1497          or return $mt->trans_error( "Load of blog '[_1]' failed: [_2]",
1498            $blog_id, MT::Blog->errstr );
1499    }
1500
1501    my (@res);
1502
1503    my $send_updates = 1;
1504    if ( exists $param{OldStatus} ) {
1505        ## If this is a new entry (!$old_status) OR the status was previously
1506        ## set to draft, and is now set to publish, send the update pings.
1507        my $old_status = $param{OldStatus};
1508        if ( $old_status && $old_status eq MT::Entry::RELEASE() ) {
1509            $send_updates = 0;
1510        }
1511    }
1512
1513    if ( $send_updates && !( MT->config->DisableNotificationPings ) ) {
1514        ## Send update pings.
1515        my @updates = $mt->update_ping_list($blog);
1516        for my $url (@updates) {
1517            require MT::XMLRPC;
1518            if ( MT::XMLRPC->ping_update( 'weblogUpdates.ping', $blog, $url ) )
1519            {
1520                push @res, { good => 1, url => $url, type => "update" };
1521            }
1522            else {
1523                push @res,
1524                  {
1525                    good  => 0,
1526                    url   => $url,
1527                    type  => "update",
1528                    error => MT::XMLRPC->errstr
1529                  };
1530            }
1531        }
1532        if ( $blog->mt_update_key ) {
1533            require MT::XMLRPC;
1534            if ( MT::XMLRPC->mt_ping($blog) ) {
1535                push @res,
1536                  {
1537                    good => 1,
1538                    url  => $mt->{cfg}->MTPingURL,
1539                    type => "update"
1540                  };
1541            }
1542            else {
1543                push @res,
1544                  {
1545                    good  => 0,
1546                    url   => $mt->{cfg}->MTPingURL,
1547                    type  => "update",
1548                    error => MT::XMLRPC->errstr
1549                  };
1550            }
1551        }
1552    }
1553
1554    my $cfg     = $mt->{cfg};
1555    my $send_tb = $cfg->OutboundTrackbackLimit;
1556    return \@res if $send_tb eq 'off';
1557
1558    my @tb_domains;
1559    if ( $send_tb eq 'selected' ) {
1560        @tb_domains = $cfg->OutboundTrackbackDomains;
1561    }
1562    elsif ( $send_tb eq 'local' ) {
1563        my $iter = MT::Blog->load_iter();
1564        while ( my $b = $iter->() ) {
1565            next if $b->id == $blog->id;
1566            push @tb_domains, MT::Util::extract_domains( $b->site_url );
1567        }
1568    }
1569    my $tb_domains;
1570    if (@tb_domains) {
1571        $tb_domains = '';
1572        my %seen;
1573        local $_;
1574        foreach (@tb_domains) {
1575            next unless $_;
1576            $_ = lc($_);
1577            next if $seen{$_};
1578            $tb_domains .= '|' if $tb_domains ne '';
1579            $tb_domains .= quotemeta($_);
1580            $seen{$_} = 1;
1581        }
1582        $tb_domains = '(' . $tb_domains . ')' if $tb_domains;
1583    }
1584
1585    ## Send TrackBack pings.
1586    if ( my $entry = $param{Entry} ) {
1587        my $pings = $entry->to_ping_url_list;
1588
1589        my %pinged = map { $_ => 1 } @{ $entry->pinged_url_list };
1590        my $cats = $entry->categories;
1591        for my $cat (@$cats) {
1592            push @$pings, grep !$pinged{$_}, @{ $cat->ping_url_list };
1593        }
1594
1595        my $ua = MT->new_ua;
1596
1597        ## Build query string to be sent on each ping.
1598        my @qs;
1599        push @qs, 'title=' . MT::Util::encode_url( $entry->title );
1600        push @qs, 'url=' . MT::Util::encode_url( $entry->permalink );
1601        push @qs, 'excerpt=' . MT::Util::encode_url( $entry->get_excerpt );
1602        push @qs, 'blog_name=' . MT::Util::encode_url( $blog->name );
1603        my $qs = join '&', @qs;
1604
1605        ## Character encoding--best guess.
1606        my $enc = $mt->{cfg}->PublishCharset;
1607
1608        for my $url (@$pings) {
1609            $url =~ s/^\s*//;
1610            $url =~ s/\s*$//;
1611            my $url_domain;
1612            ($url_domain) = MT::Util::extract_domains($url);
1613            next if $tb_domains && lc($url_domain) !~ m/$tb_domains$/;
1614
1615            my $req = HTTP::Request->new( POST => $url );
1616            $req->content_type(
1617                "application/x-www-form-urlencoded; charset=$enc");
1618            $req->content($qs);
1619            my $res = $ua->request($req);
1620            if ( substr( $res->code, 0, 1 ) eq '2' ) {
1621                my $c = $res->content;
1622                my ( $error, $msg ) =
1623                  $c =~ m!<error>(\d+).*<message>(.+?)</message>!s;
1624                if ($error) {
1625                    push @res,
1626                      {
1627                        good  => 0,
1628                        url   => $url,
1629                        type  => 'trackback',
1630                        error => $msg
1631                      };
1632                }
1633                else {
1634                    push @res, { good => 1, url => $url, type => 'trackback' };
1635                }
1636            }
1637            else {
1638                push @res,
1639                  {
1640                    good  => 0,
1641                    url   => $url,
1642                    type  => 'trackback',
1643                    error => "HTTP error: " . $res->status_line
1644                  };
1645            }
1646        }
1647    }
1648    \@res;
1649}
1650
1651sub ping_and_save {
1652    my $mt    = shift;
1653    my %param = @_;
1654    if ( my $entry = $param{Entry} ) {
1655        my $results = MT::ping( $mt, @_ ) or return;
1656        my %still_ping;
1657        my $pinged = $entry->pinged_url_list;
1658        for my $res (@$results) {
1659            next if $res->{type} ne 'trackback';
1660            if ( !$res->{good} ) {
1661                $still_ping{ $res->{url} } = 1;
1662            }
1663            push @$pinged,
1664              $res->{url}
1665              . ( $res->{good}
1666                ? ''
1667                : ' ' . MT::I18N::encode_text( $res->{error} ) );
1668        }
1669        $entry->pinged_urls( join "\n", @$pinged );
1670        $entry->to_ping_urls( join "\n", keys %still_ping );
1671        $entry->save or return $mt->error( $entry->errstr );
1672        return $results;
1673    }
1674    1;
1675}
1676
1677sub needs_ping {
1678    my $mt    = shift;
1679    my %param = @_;
1680    my $blog  = $param{Blog};
1681    my $entry = $param{Entry};
1682    require MT::Entry;
1683    return unless $entry->status == MT::Entry::RELEASE();
1684    my $old_status = $param{OldStatus};
1685    my %list;
1686    ## If this is a new entry (!$old_status) OR the status was previously
1687    ## set to draft, and is now set to publish, send the update pings.
1688    if ( ( !$old_status || $old_status ne MT::Entry::RELEASE() )
1689        && !( MT->config->DisableNotificationPings ) )
1690    {
1691        my @updates = $mt->update_ping_list($blog);
1692        @list{@updates} = (1) x @updates;
1693        $list{ $mt->{cfg}->MTPingURL } = 1 if $blog && $blog->mt_update_key;
1694    }
1695    if ($entry) {
1696        @list{ @{ $entry->to_ping_url_list } } = ();
1697        my %pinged = map { $_ => 1 } @{ $entry->pinged_url_list };
1698        my $cats = $entry->categories;
1699        for my $cat (@$cats) {
1700            @list{ grep !$pinged{$_}, @{ $cat->ping_url_list } } = ();
1701        }
1702    }
1703    my @list = keys %list;
1704    return unless @list;
1705    \@list;
1706}
1707
1708sub update_ping_list {
1709    my $mt = shift;
1710    my ($blog) = @_;
1711
1712    my @updates;
1713    if ( my $pings = MT->registry('ping_servers') ) {
1714        my $up = $blog->update_pings;
1715        if ($up) {
1716            foreach ( split ',', $up ) {
1717                next unless exists $pings->{$_};
1718                push @updates, $pings->{$_}->{url};
1719            }
1720        }
1721    }
1722    if ( my $others = $blog->ping_others ) {
1723        push @updates, split /\r?\n/, $others;
1724    }
1725    my %updates;
1726    for my $url (@updates) {
1727        for ($url) {
1728            s/^\s*//;
1729            s/\s*$//;
1730        }
1731        next unless $url =~ /\S/;
1732        $updates{$url}++;
1733    }
1734    keys %updates;
1735}
1736
1737{
1738    my $LH;
1739
1740    sub set_language {
1741        my $pkg = shift;
1742        require MT::L10N;
1743        $LH = MT::L10N->get_handle(@_);
1744
1745        # Clear any l10n_handles in request
1746        $pkg->request( 'l10n_handle', {} );
1747        return $LH;
1748    }
1749
1750    require MT::I18N;
1751
1752    sub translate {
1753        my $this = shift;
1754        my $app = ref($this) ? $this : $this->app;
1755        if ( $app->{component} ) {
1756            if ( my $c = $app->component( $app->{component} ) ) {
1757                local $app->{component} = undef;
1758                return $c->translate(@_);
1759            }
1760        }
1761        my ( $format, @args ) = @_;
1762        foreach (@args) {
1763            $_ = $_->() if ref($_) eq 'CODE';
1764        }
1765        my $enc = MT->instance->config('PublishCharset') || 'utf-8';
1766        return $LH->maketext( $format, @args ) if $enc =~ m/utf-?8/i;
1767        $format = MT::I18N::encode_text( $format, $enc, 'utf-8' );
1768        MT::I18N::encode_text(
1769            $LH->maketext(
1770                $format,
1771                map { MT::I18N::encode_text( $_, $enc, 'utf-8' ) } @args
1772            ),
1773            'utf-8', $enc
1774        );
1775    }
1776
1777    sub translate_templatized {
1778        my $mt = shift;
1779        my $app = ref($mt) ? $mt : $mt->app;
1780        if ( $app->{component} ) {
1781            if ( my $c = $app->component( $app->{component} ) ) {
1782                local $app->{component} = undef;
1783                return $c->translate_templatized(@_);
1784            }
1785        }
1786        my @cstack;
1787        my ($text) = @_;
1788        while (1) {
1789            $text =~ s!(<(/)?(?:_|MT)_TRANS(_SECTION)?(?:(?:\s+((?:\w+)\s*=\s*(["'])(?:(<(?:[^"'>]|"[^"]*"|'[^']*')+)?>|[^\5]+?)*?\5))+?\s*/?)?>)!
1790            my($msg, $close, $section, %args) = ($1, $2, $3);
1791            while ($msg =~ /\b(\w+)\s*=\s*(["'])((?:<(?:[^"'>]|"[^"]*"|'[^']*')+?>|[^\2])*?)?\2/g) {  #"
1792                $args{$1} = $3;
1793            }
1794            if ($section) {
1795                if ($close) {
1796                    $mt = pop @cstack;
1797                } else {
1798                    if ($args{component}) {
1799                        push @cstack, $mt;
1800                        $mt = MT->component($args{component})
1801                            or die "Bad translation component: $args{component}";
1802                    }
1803                    else {
1804                        die "__trans_section without a component argument";
1805                    }
1806                }
1807                '';
1808            }
1809            else {
1810                $args{params} = '' unless defined $args{params};
1811                my @p = map MT::Util::decode_html($_),
1812                        split /\s*%%\s*/, $args{params}, -1;
1813                @p = ('') unless @p;
1814                my $translation = $mt->translate($args{phrase}, @p);
1815                if (exists $args{escape}) {
1816                    if (lc($args{escape}) eq 'html') {
1817                        $translation = MT::Util::encode_html($translation);
1818                    } elsif (lc($args{escape}) eq 'url') {
1819                        $translation = MT::Util::encode_url($translation);
1820                    } else {
1821                        # fallback for js/javascript/singlequotes
1822                        $translation = MT::Util::encode_js($translation);
1823                    }
1824                }
1825                $translation;
1826            }
1827            !igem or last;
1828        }
1829        return $text;
1830    }
1831
1832    sub current_language { $LH->language_tag }
1833    sub language_handle  { $LH }
1834
1835    sub charset {
1836        my $mt = shift;
1837        $mt->{charset} = shift if @_;
1838        return $mt->{charset} if $mt->{charset};
1839        $mt->{charset} = $mt->config->PublishCharset
1840          || $mt->language_handle->encoding;
1841    }
1842}
1843
1844sub supported_languages {
1845    my $mt = shift;
1846    require MT::L10N;
1847    require File::Basename;
1848    ## Determine full path to lib/MT/L10N directory...
1849    my $lib =
1850      File::Spec->catdir( File::Basename::dirname( $INC{'MT/L10N.pm'} ),
1851        'L10N' );
1852    ## ... From that, determine full path to extlib/MT/L10N.
1853    ## To do that, we look for the last instance of the string 'lib'
1854    ## in $lib and replace it with 'extlib'. reverse is a nice tricky
1855    ## way of doing that.
1856    ( my $extlib = reverse $lib ) =~ s!bil!biltxe!;
1857    $extlib = reverse $extlib;
1858    my @dirs = ( $lib, $extlib );
1859    my %langs;
1860    for my $dir (@dirs) {
1861        opendir DH, $dir or next;
1862        for my $f ( readdir DH ) {
1863            my ($tag) = $f =~ /^(\w+)\.pm$/;
1864            next unless $tag;
1865            my $lh = MT::L10N->get_handle($tag);
1866            $langs{ $lh->language_tag } = $lh->language_name;
1867        }
1868        closedir DH;
1869    }
1870    \%langs;
1871}
1872
1873# For your convenience
1874sub trans_error {
1875    my $app = shift;
1876    $app->error( $app->translate(@_) );
1877}
1878
1879sub all_text_filters {
1880    unless (%Text_filters) {
1881        if ( my $filters = MT->registry('text_filters') ) {
1882            %Text_filters = %$filters if ref($filters) eq 'HASH';
1883        }
1884    }
1885    if (my $enabled_filters = MT->config('AllowedTextFilters')) {
1886        my %enabled = map { $_ => 1 } split /\s*,\s*/, $enabled_filters;
1887        %Text_filters = map { $_ => $Text_filters{$_} }
1888                        grep { exists $enabled{$_} }
1889                        keys %Text_filters;
1890    }
1891    return \%Text_filters;
1892}
1893
1894sub apply_text_filters {
1895    my $mt = shift;
1896    my ( $str, $filters, @extra ) = @_;
1897    my $all_filters = $mt->all_text_filters;
1898    for my $filter (@$filters) {
1899        my $f = $all_filters->{$filter} or next;
1900        my $code = $f->{code} || $f->{handler};
1901        unless ( ref($code) eq 'CODE' ) {
1902            $code = $mt->handler_to_coderef($code);
1903            $f->{code} = $code;
1904        }
1905        if ( !$code ) {
1906            warn "Bad text filter: $filter";
1907            next;
1908        }
1909        $str = $code->( $str, @extra );
1910    }
1911    return $str;
1912}
1913
1914sub static_path {
1915    my $app = shift;
1916    my $spath = $app->config->StaticWebPath;
1917    if (!$spath) {
1918        $spath = $app->config->CGIPath;
1919        $spath .= '/' unless $spath =~ m!/$!;
1920        $spath .= 'mt-static/';
1921    } else {
1922        $spath .= '/' unless $spath =~ m!/$!;
1923    }
1924    $spath;
1925}
1926
1927sub static_file_path {
1928    my $app = shift;
1929    return $app->{__static_file_path}
1930        if exists $app->{__static_file_path};
1931
1932    my $path = $app->config('StaticFilePath');
1933    return $app->{__static_file_path} = $path if defined $path;
1934
1935    # Attempt to derive StaticFilePath based on environment
1936    my $web_path = $app->config->StaticWebPath || 'mt-static';
1937    $web_path =~ s!^https?://[^/]+/!!;
1938    if ($app->can('document_root')) {
1939        my $doc_static_path = File::Spec->catdir($app->document_root(), $web_path);
1940        return $app->{__static_file_path} = $doc_static_path
1941            if -d $doc_static_path;
1942    }
1943    my $mtdir_static_path = File::Spec->catdir($app->mt_dir, 'mt-static');
1944    return $app->{__static_file_path} = $mtdir_static_path
1945        if -d $mtdir_static_path;
1946    return;
1947}
1948
1949sub template_paths {
1950    my $mt = shift;
1951    my @paths;
1952    my $path = $mt->config->TemplatePath;
1953    if ($mt->{plugin_template_path}) {
1954        if (File::Spec->file_name_is_absolute($mt->{plugin_template_path})) {
1955            push @paths, $mt->{plugin_template_path}
1956                if -d $mt->{plugin_template_path};
1957        } else {
1958            my $dir = File::Spec->catdir($mt->app_dir,
1959                                         $mt->{plugin_template_path});
1960            if (-d $dir) {
1961                push @paths, $dir;
1962            } else {
1963                $dir = File::Spec->catdir($mt->mt_dir,
1964                                          $mt->{plugin_template_path});
1965                push @paths, $dir if -d $dir;
1966            }
1967        }
1968    }
1969    if (my $alt_path = $mt->config->AltTemplatePath) {
1970        if (-d $alt_path) {    # AltTemplatePath is absolute
1971            push @paths, File::Spec->catdir($alt_path,
1972                                            $mt->{template_dir})
1973                if $mt->{template_dir};
1974            push @paths, $alt_path;
1975        }
1976    }
1977 
1978    for my $addon ( @{ $mt->find_addons('pack') } ) {
1979        push @paths, File::Spec->catdir($addon->{path}, 'tmpl', $mt->{template_dir})
1980            if $mt->{template_dir};
1981        push @paths, File::Spec->catdir($addon->{path}, 'tmpl');
1982    }
1983
1984    push @paths, File::Spec->catdir($path, $mt->{template_dir})
1985        if $mt->{template_dir};
1986    push @paths, $path;
1987 
1988    return @paths;
1989}
1990
1991sub find_file {
1992    my $mt = shift;
1993    my ($paths, $file) = @_;
1994    my $filename;
1995    foreach my $p (@$paths) {
1996        my $filepath = File::Spec->canonpath(File::Spec->catfile($p, $file));
1997        $filename = File::Spec->canonpath($filepath);
1998        return $filename if -f $filename;
1999    }
2000    undef;
2001}
2002
2003sub load_tmpl {
2004    my $mt = shift;
2005    if ($mt->{component}) {
2006        if (my $c = $mt->component($mt->{component})) {
2007            return $c->load_tmpl(@_);
2008        }
2009    }
2010
2011    my($file, @p) = @_;
2012    my $param;
2013    if (@p && (ref($p[$#p]) eq 'HASH')) {
2014        $param = pop @p;
2015    }
2016    my $cfg = $mt->config;
2017    require MT::Template;
2018    my $tmpl;
2019    my @paths = $mt->template_paths;
2020
2021    my $type = {'SCALAR' => 'scalarref', 'ARRAY' => 'arrayref'}->{ref $file}
2022        || 'filename';
2023    $tmpl = MT::Template->new(
2024        type => $type, source => $file,
2025        path => \@paths,
2026        filter => sub {
2027            my ($str, $fname) = @_;
2028            if ($fname) {
2029                $fname = File::Basename::basename($fname);
2030                $fname =~ s/\.tmpl$//;
2031                $mt->run_callbacks("template_source.$fname", $mt, @_);
2032            } else {
2033                $mt->run_callbacks("template_source", $mt, @_);
2034            }
2035            return $str;
2036        },
2037        @p);
2038    return $mt->error(
2039        $mt->translate("Loading template '[_1]' failed.", $file)) unless $tmpl;
2040    $mt->set_default_tmpl_params($tmpl);
2041    $tmpl->param($param) if $param;
2042    $tmpl;
2043}
2044
2045sub set_default_tmpl_params {
2046    my $mt = shift;
2047    my ($tmpl) = @_;
2048    my $param = {};
2049    $param->{mt_debug} = $MT::DebugMode;
2050    $param->{mt_beta} = 1 if MT->version_id =~ m/^\d+\.\d+(?:a|b|rc)/;
2051    $param->{static_uri} = $mt->static_path;
2052    $param->{mt_version} = MT->version_number;
2053    $param->{mt_version_id} = MT->version_id;
2054    $param->{mt_product_code} = MT->product_code;
2055    $param->{mt_product_name} = $mt->translate(MT->product_name);
2056    $param->{language_tag} = substr($mt->current_language, 0, 2);
2057    $param->{language_encoding} = $mt->charset;
2058    if ($mt->isa('MT::App')) {
2059        if (my $author = $mt->user) {
2060            $param->{author_id} = $author->id;
2061            $param->{author_name} = $author->name;
2062        }
2063        ## We do this in load_tmpl because show_error and login don't call
2064        ## build_page; so we need to set these variables here.
2065        require MT::Auth;
2066        $param->{can_logout} = MT::Auth->can_logout;
2067        $param->{script_url} = $mt->uri;
2068        $param->{mt_url} = $mt->mt_uri;
2069        $param->{script_path} = $mt->path;
2070        $param->{script_full_url} = $mt->base . $mt->uri;
2071        $param->{agent_mozilla} = ( $ENV{HTTP_USER_AGENT} || '' ) =~ /gecko/i;
2072        $param->{agent_ie} = ( $ENV{HTTP_USER_AGENT} || '' ) =~ /\bMSIE\b/;
2073    }
2074    if (!$tmpl->param('template_filename')) {
2075        if (my $fname = $tmpl->{__file}) {
2076            $fname =~ s!\\!/!g;
2077            $fname =~ s/\.tmpl$//;
2078            $param->{template_filename} = $fname;
2079        }
2080    }
2081    $tmpl->param($param);
2082}
2083
2084sub process_mt_template {
2085    my $mt = shift;
2086    my ($body) = @_;
2087    $body =~ s@<(?:_|MT)_ACTION\s+mode="([^"]+)"(?:\s+([^>]*))?>@
2088        my $mode = $1; my %args;
2089        %args = $2 =~ m/\s*(\w+)="([^"]*?)"\s*/g if defined $2; # "
2090        MT::Util::encode_html($mt->uri(mode => $mode, args => \%args));
2091    @geis;
2092    # Strip out placeholder wrappers to facilitate tmpl_* callbacks
2093    $body =~ s/<\/?MT_(\w+):(\w+)>//g;
2094    $body;
2095}
2096
2097sub build_page {
2098    my $mt = shift;
2099    my($file, $param) = @_;
2100    my $tmpl;
2101    my $mode = $mt->mode;
2102    $param->{"mode_$mode"} ||= 1;
2103    $param->{breadcrumbs} = $mt->{breadcrumbs};
2104    if ($param->{breadcrumbs}[-1]) {
2105        $param->{breadcrumbs}[-1]{is_last} = 1;
2106        $param->{page_titles} = [ reverse @{ $mt->{breadcrumbs} } ];
2107    }
2108    pop @{ $param->{page_titles} };
2109    if (my $lang_id = $mt->current_language) {
2110        $param->{local_lang_id} ||= lc $lang_id;
2111    }
2112    $param->{magic_token} = $mt->current_magic if $mt->user;
2113
2114    # List of installed packs in the application footer
2115    my @packs_installed;
2116    my $packs = $mt->find_addons('pack');
2117    if ($packs) {
2118        foreach my $pack (@$packs) {
2119            my $c = $mt->component(lc $pack->{id});
2120            if ($c) {
2121                my $label = $c->label || $pack->{label};
2122                $label = $label->() if ref($label) eq 'CODE';
2123                push @packs_installed, {
2124                    label => $label,
2125                    version => $c->version,
2126                    id => $c->id,
2127                };
2128            }
2129        }
2130    }
2131    @packs_installed = sort { $a->{label} cmp $b->{label} } @packs_installed;
2132    $param->{packs_installed} = \@packs_installed;
2133    $param->{portal_url} = $mt->translate("__PORTAL_URL__");
2134
2135    for my $config_field (keys %{ MT::ConfigMgr->instance->{__var} || {} }) {
2136        $param->{ $config_field . '_readonly' } = 1;
2137    }
2138
2139    my $tmpl_file = '';
2140    if (UNIVERSAL::isa($file, 'MT::Template')) {
2141        $tmpl = $file;
2142        $tmpl_file = (exists $file->{__file}) ? $file->{__file} : '';
2143    } else {
2144        $tmpl = $mt->load_tmpl($file) or return;
2145        $tmpl_file = $file unless ref($file);
2146    }
2147
2148    if (($mode && ($mode !~ m/delete/)) && ($mt->{login_again} ||
2149        ($mt->{requires_login} && !$mt->user))) {
2150        ## If it's a login screen, direct the user to where they were going
2151        ## (query params including mode and all) unless they were logging in,
2152        ## logging out, or deleting something.
2153        my $q = $mt->{query};
2154        if ($mode) {
2155            my @query = map { { name => $_, value => scalar encode_text( $q->param($_) ) }; }
2156                grep { ($_ ne 'username') && ($_ ne 'password') && ($_ ne 'submit') && ($mode eq 'logout' ? ($_ ne '__mode') : 1) } $q->param;
2157            $param->{query_params} = \@query;
2158        }
2159        $param->{login_again} = $mt->{login_again};
2160    }
2161
2162    my $blog = $mt->blog;
2163    $tmpl->context()->stash('blog', $blog) if $blog;
2164
2165    $tmpl->param($param) if $param;
2166
2167    if ($tmpl_file) {
2168        $tmpl_file = File::Basename::basename($tmpl_file);
2169        $tmpl_file =~ s/\.tmpl$//;
2170        $tmpl_file = '.' . $tmpl_file;
2171    }
2172    $mt->run_callbacks('template_param' . $tmpl_file, $mt, $tmpl->param, $tmpl);
2173
2174    my $output = $mt->build_page_in_mem($tmpl);
2175    return unless defined $output;
2176
2177    $mt->run_callbacks('template_output' . $tmpl_file, $mt, \$output, $tmpl->param, $tmpl);
2178    return $output;
2179}
2180
2181sub build_page_in_mem {
2182    my $mt = shift;
2183    my($tmpl, $param) = @_;
2184    $tmpl->param($param) if $param;
2185    my $out = $tmpl->output;
2186    return $mt->error($tmpl->errstr) unless defined $out;
2187    return $mt->translate_templatized($mt->process_mt_template($out));
2188}
2189
2190sub new_ua {
2191    my $class = shift;
2192    my ($opt) = @_;
2193    $opt ||= {};
2194    my $lwp_class = 'LWP::UserAgent';
2195    if ($opt->{paranoid}) {
2196        eval { require LWPx::ParanoidAgent; };
2197        $lwp_class = 'LWPx::ParanoidAgent' unless $@;
2198    }
2199    eval "require $lwp_class;";
2200    return undef if $@;
2201    my $cfg = $class->config;
2202    my $max_size = exists $opt->{max_size} ? $opt->{max_size} : 100_000;
2203    my $timeout = exists $opt->{timeout} ? $opt->{timeout} : $cfg->HTTPTimeout || $cfg->PingTimeout;
2204    my $proxy = exists $opt->{proxy} ? $opt->{proxy} : $cfg->HTTPProxy || $cfg->PingProxy;
2205    my $no_proxy = exists $opt->{no_proxy} ? $opt->{no_proxy} : $cfg->HTTPNoProxy || $cfg->PingNoProxy;
2206    my $agent = $opt->{agent} || 'MovableType/' . $MT::VERSION;
2207    my $interface = exists $opt->{interface} ? $opt->{interface} : $cfg->HTTPInterface || $cfg->PingInterface;
2208
2209    if ( my $localaddr = $interface ) {
2210        @LWP::Protocol::http::EXTRA_SOCK_OPTS = (
2211            LocalAddr => $localaddr,
2212            Reuse     => 1
2213        );
2214    }
2215
2216    my $ua = $lwp_class->new;
2217    $ua->max_size($max_size) if (defined $max_size) && $ua->can('max_size');
2218    $ua->agent( $agent );
2219    $ua->timeout( $timeout ) if defined $timeout;
2220    if ( defined $proxy ) {
2221        $ua->proxy( http => $proxy );
2222        my @domains = split( /,\s*/, $no_proxy ) if $no_proxy;
2223        $ua->no_proxy(@domains) if @domains;
2224    }
2225    return $ua;
2226}
2227
2228sub build_email {
2229    my $class = shift;
2230    my ( $file, $param ) = @_;
2231    my $mt = $class->instance;
2232
2233    # basically, try to load from database
2234    my $blog = $param->{blog} || undef;
2235    my $id = $file;
2236    $id =~ s/(\.tmpl|\.mtml)$//;
2237
2238    require MT::Template;
2239    my @tmpl = MT::Template->load(
2240        {
2241            ( $blog ? ( blog_id => [ $blog->id, 0 ] ) : ( blog_id => 0 ) ),
2242            identifier => $id,
2243            type       => 'email',
2244        }
2245    );
2246    my $tmpl =
2247      @tmpl
2248      ? (
2249        scalar @tmpl > 1
2250        ? ( $tmpl[0]->blog_id ? $tmpl[0] : $tmpl[1] )
2251        : $tmpl[0]
2252      )
2253      : undef;
2254
2255    # try to load from file
2256    unless ($tmpl) {
2257        local $mt->{template_dir} = 'email';
2258        $tmpl = $mt->load_tmpl($file);
2259    }
2260    return unless $tmpl;
2261
2262    my $ctx = $tmpl->context;
2263    $ctx->stash( 'blog',   delete $param->{'blog'} )   if $param->{'blog'};
2264    $ctx->stash( 'entry',  delete $param->{'entry'} )  if $param->{'entry'};
2265    $ctx->stash( 'author', delete $param->{'author'} ) if $param->{'author'};
2266    $ctx->stash( 'commenter', delete $param->{'commenter'} )
2267      if $param->{'commenter'};
2268    $ctx->stash( 'comment', delete $param->{'comment'} ) if $param->{'comment'};
2269    $ctx->stash( 'category', delete $param->{'category'} )
2270      if $param->{'category'};
2271    $ctx->stash( 'ping', delete $param->{'ping'} ) if $param->{'ping'};
2272
2273    foreach my $p (%$param) {
2274        if ( ref($p) ) {
2275            $tmpl->param( $p, $param->{$p} );
2276        }
2277    }
2278    return $mt->build_page_in_mem( $tmpl, $param );
2279}
2280
2281sub get_next_sched_post_for_user {
2282    my ( $author_id, @further_blog_ids ) = @_;
2283    require MT::Permission;
2284    my @perms = MT::Permission->load( { author_id => $author_id }, {} );
2285    my @blogs = @further_blog_ids;
2286    for my $perm (@perms) {
2287        next
2288          unless ( $perm->can_edit_config
2289            || $perm->can_publish_post
2290            || $perm->can_edit_all_posts );
2291        push @blogs, $perm->blog_id;
2292    }
2293    my $next_sched_utc = undef;
2294    require MT::Entry;
2295    for my $blog_id (@blogs) {
2296        my $blog           = MT::Blog->load($blog_id)
2297            or next;
2298        my $earliest_entry = MT::Entry->load(
2299            {
2300                status  => MT::Entry::FUTURE(),
2301                blog_id => $blog_id
2302            },
2303            { 'sort' => 'created_on' }
2304        );
2305        if ($earliest_entry) {
2306            my $entry_utc =
2307              MT::Util::ts2iso( $blog, $earliest_entry->created_on );
2308            if ( $entry_utc < $next_sched_utc || !defined($next_sched_utc) ) {
2309                $next_sched_utc = $entry_utc;
2310            }
2311        }
2312    }
2313    return $next_sched_utc;
2314}
2315
2316our %Commenter_Auth;
2317
2318sub init_commenter_authenticators {
2319    my $self = shift;
2320    my $auths = $self->registry("commenter_authenticators") || {};
2321    foreach my $auth ( keys %$auths ) {
2322        delete $auths->{$auth}
2323          if exists( $auths->{$auth}->{condition} )
2324          && !( $auths->{$auth}->{condition}->() );
2325    }
2326    %Commenter_Auth = %$auths;
2327    $Commenter_Auth{$_}{key} ||= $_ for keys %Commenter_Auth;
2328}
2329
2330sub commenter_authenticator {
2331    my $self = shift;
2332    my ($key) = @_;
2333    %Commenter_Auth or $self->init_commenter_authenticators();
2334    return $Commenter_Auth{$key};
2335}
2336
2337sub commenter_authenticators {
2338    my $self = shift;
2339    %Commenter_Auth or $self->init_commenter_authenticators();
2340    return values %Commenter_Auth;
2341}
2342
2343sub _commenter_auth_params {
2344    my ( $key, $blog_id, $entry_id, $static ) = @_;
2345    my $params = {
2346        blog_id => $blog_id,
2347        static  => $static,
2348    };
2349    $params->{entry_id} = $entry_id if defined $entry_id;
2350    return $params;
2351}
2352
2353sub _openid_commenter_condition {
2354    eval "require Digest::SHA1;";
2355    return $@ ? 0 : 1;
2356}
2357
2358sub core_commenter_authenticators {
2359    return {
2360        'OpenID' => {
2361            class      => 'MT::Auth::OpenID',
2362            label      => 'OpenID',
2363            login_form => <<OpenID,
2364<form method="post" action="<mt:var name="script_url">">
2365<input type="hidden" name="__mode" value="login_external" />
2366<input type="hidden" name="blog_id" value="<mt:var name="blog_id">" />
2367<input type="hidden" name="entry_id" value="<mt:var name="entry_id">" />
2368<input type="hidden" name="static" value="<mt:var name="static" escape="html">" />
2369<fieldset>
2370<mtapp:setting
2371    id="openid_display"
2372    label="<__trans phrase="OpenID URL">"
2373    hint="<__trans phrase="Sign in using your OpenID identity.">">
2374<input type="hidden" name="key" value="OpenID" />
2375<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%;" />
2376    <p class="hint"><__trans phrase="OpenID is an open and decentralized single sign-on identity system."></p>
2377</mtapp:setting>
2378
2379<div class="pkg">
2380<div class="left"><input type="submit" name="submit" value="<__trans phrase="Sign In">" /></div>
2381<div class="right"><img src="<mt:var name="static_uri">images/comment/openid_enabled.png" /></div>
2382</div>
2383<p><img src="<mt:var name="static_uri">images/comment/blue_moreinfo.png"> <a href="http://www.openid.net/"><__trans phrase="Learn more about OpenID."></a></p>
2384</fieldset>
2385</form>
2386OpenID
2387            login_form_params => \&_commenter_auth_params,
2388            condition         => \&_openid_commenter_condition,
2389            logo              => 'images/comment/signin_openid.png',
2390            logo_small        => 'images/comment/openid_logo.png',
2391        },
2392        'LiveJournal' => {
2393            class      => 'MT::Auth::LiveJournal',
2394            label      => 'LiveJournal',
2395            login_form => <<LiveJournal,
2396<form method="post" action="<mt:var name="script_url">">
2397<input type="hidden" name="__mode" value="login_external" />
2398<input type="hidden" name="blog_id" value="<mt:var name="blog_id">" />
2399<input type="hidden" name="entry_id" value="<mt:var name="entry_id">" />
2400<input type="hidden" name="static" value="<mt:var name="static" escape="html">" />
2401<input type="hidden" name="key" value="LiveJournal" />
2402<fieldset>
2403<mtapp:setting
2404    id="livejournal_display"
2405    label="<__trans phrase="Your LiveJournal Username">"
2406    hint="<__trans phrase="Sign in using your Vox blog URL">">
2407<input name="openid_userid" style="background: #fff url('<mt:var name="static_uri">images/comment/livejournal_logo.png') no-repeat 2px center; padding: 2px 2px 2px 20px; border: 1px solid #5694b6; width: 300px; font-size: 110%;" />
2408</mtapp:setting>
2409<div class="actions-bar actions-bar-login">
2410    <div class="actions-bar-inner pkg actions">
2411        <button
2412            type="submit"
2413            class="primary-button"
2414            ><__trans phrase="Sign in"></button>
2415    </div>
2416</div>
2417<p><img src="<mt:var name="static_uri">images/comment/blue_moreinfo.png"> <a href="http://www.livejournal.com/"><__trans phrase="Learn more about LiveJournal."></a></p>
2418</fieldset>
2419</form>
2420LiveJournal
2421            login_form_params => \&_commenter_auth_params,
2422            condition         => \&_openid_commenter_condition,
2423            logo              => 'images/comment/signin_livejournal.png',
2424            logo_small        => 'images/comment/livejournal_logo.png',
2425        },
2426        'Vox' => {
2427            class      => 'MT::Auth::Vox',
2428            label      => 'Vox',
2429            login_form => <<Vox,
2430<form method="post" action="<mt:var name="script_url">">
2431<input type="hidden" name="__mode" value="login_external" />
2432<input type="hidden" name="blog_id" value="<mt:var name="blog_id">" />
2433<input type="hidden" name="entry_id" value="<mt:var name="entry_id">" />
2434<input type="hidden" name="static" value="<mt:var name="static" escape="html">" />
2435<input type="hidden" name="key" value="Vox" />
2436<fieldset>
2437<mtapp:setting
2438    id="vox_display"
2439    label="<__trans phrase="Your Vox Blog URL">">
2440http:// <input name="openid_userid" style="background: #fff url('<mt:var name="static_uri">images/comment/vox_logo.png') no-repeat 2px center; padding: 2px 2px 2px 20px; border: 1px solid #5694b6; width: 200px; font-size: 110%; vertical-align: middle" />.vox.com
2441</mtapp:setting>
2442<div class="actions-bar actions-bar-login">
2443    <div class="actions-bar-inner pkg actions">
2444        <button
2445            type="submit"
2446            class="primary-button"
2447            ><__trans phrase="Sign in"></button>
2448    </div>
2449</div>
2450<p><img src="<mt:var name="static_uri">images/comment/blue_moreinfo.png"> <a href="http://www.vox.com/"><__trans phrase="Learn more about Vox."></a></p>
2451</fieldset>
2452</form>
2453Vox
2454            login_form_params => \&_commenter_auth_params,
2455            condition         => \&_openid_commenter_condition,
2456            logo              => 'images/comment/signin_vox.png',
2457            logo_small        => 'images/comment/vox_logo.png',
2458        },
2459        'TypeKey' => {
2460            class      => 'MT::Auth::TypeKey',
2461            label      => 'TypeKey',
2462            login_form => <<TypeKey,
2463<p class="hint"><__trans phrase="TypeKey is a free, open system providing you a central identity for posting comments on weblogs and logging into other websites. You can register for free."></p>
2464<p><img src="<mt:var name="static_uri">images/comment/blue_goto.png"> <a href="<mt:var name="tk_signin_url">"><__trans phrase="Sign in or register with TypeKey."></a></p>
2465TypeKey
2466            login_form_params => sub {
2467                my ( $key, $blog_id, $entry_id, $static ) = @_;
2468                my $entry = MT::Entry->load($entry_id) if $entry_id;
2469
2470                ## TypeKey URL
2471                require MT::Template::Context;
2472                my $ctx = MT::Template::Context->new;
2473                $ctx->stash( 'blog_id', $blog_id );
2474                my $blog = MT::Blog->load($blog_id);
2475                $ctx->stash( 'blog',  $blog );
2476                $ctx->stash( 'entry', $entry );
2477                my $params = {};
2478                $params->{tk_signin_url} =
2479                  MT::Template::Context::_hdlr_remote_sign_in_link( $ctx,
2480                    { static => $static } );
2481                return $params;
2482            },
2483            logo => 'images/comment/signin_typekey.png',
2484            logo_small        => 'images/comment/typekey_logo.png',
2485        },
2486    };
2487}
2488
2489our %Captcha_Providers;
2490
2491sub captcha_provider {
2492    my $self = shift;
2493    my ($key) = @_;
2494    $self->init_captcha_providers() unless %Captcha_Providers;
2495    return $Captcha_Providers{$key};
2496}
2497
2498sub captcha_providers {
2499    my $self = shift;
2500    $self->init_captcha_providers() unless %Captcha_Providers;
2501    my $def  = delete $Captcha_Providers{'mt_default'};
2502    my @vals = values %Captcha_Providers;
2503    if ( defined($def) && $def->{condition}->() ) {
2504        unshift @vals, $def;
2505    }
2506    @vals;
2507}
2508
2509sub core_captcha_providers {
2510    return {
2511        'mt_default' => {
2512            label     => 'Movable Type default',
2513            class     => 'MT::Util::Captcha',
2514            condition => sub {
2515                require MT::Util::Captcha;
2516                if ( my $error = MT::Util::Captcha->check_availability ) {
2517                    return 0;
2518                }
2519                1;
2520            },
2521        }
2522    };
2523}
2524
2525sub init_captcha_providers {
2526    my $self = shift;
2527    my $providers = $self->registry("captcha_providers") || {};
2528    foreach my $provider ( keys %$providers ) {
2529        delete $providers->{$provider}
2530          if exists( $providers->{$provider}->{condition} )
2531          && !( $providers->{$provider}->{condition}->() );
2532    }
2533    %Captcha_Providers = %$providers;
2534    $Captcha_Providers{$_}{key} ||= $_ for keys %Captcha_Providers;
2535}
2536
2537sub effective_captcha_provider {
2538    my $class = shift;
2539    my ($key) = @_;
2540    return undef unless $key;
2541    my $cp = $class->captcha_provider($key) or return;
2542    if ( exists $cp->{condition} ) {
2543        return undef unless $cp->{condition}->();
2544    }
2545    my $pkg = $cp->{class};
2546    $pkg =~ s/;//g;
2547    eval "require $pkg" or return;
2548    return $cp->{class};
2549}
2550
2551sub handler_to_coderef {
2552    my $pkg = shift;
2553    my ( $name, $delayed ) = @_;
2554
2555    return $name if ref($name) eq 'CODE';
2556    return undef unless defined $name && $name ne '';
2557
2558    my $code;
2559    if ( $name !~ m/->/ ) {
2560
2561        # check for Package::Routine first; if defined, return coderef
2562        no strict 'refs';
2563        $code = \&$name if defined &$name;
2564        return $code if $code;
2565    }
2566
2567    my $component;
2568    if ( $name =~ m!^\$! ) {
2569        if ( $name =~ s/^\$(\w+)::// ) {
2570            $component = $1;
2571        }
2572    }
2573    if ( $name =~ m/^\s*sub\s*\{/s ) {
2574        $code = eval $name or die $@;
2575
2576        if ($component) {
2577            return sub {
2578                my $mt_inst = MT->instance;
2579                local $mt_inst->{component} = $component;
2580                $code->(@_);
2581            };
2582        }
2583        else {
2584            return $code;
2585        }
2586    }
2587
2588    my $hdlr_pkg = $name;
2589    my $method;
2590    if ( $hdlr_pkg =~ s/(->|::)([^:]+)$// ) {    # strip routine name
2591        $method = $2 if $1 eq '->';
2592    }
2593    if ( !defined(&$name) && !$pkg->can( 'AUTOLOAD' ) ) {
2594
2595        # The delayed option will return a coderef that delays the loading
2596        # of the package holding the handler routine.
2597        if ($delayed) {
2598            if ($method) {
2599                return sub {
2600                    eval "# line " . __LINE__ . " " . __FILE__ . "\nrequire $hdlr_pkg;"
2601                      or Carp::confess(
2602                        "failed loading package $hdlr_pkg for routine $name: $@");
2603                    my $mt_inst = MT->instance;
2604                    local $mt_inst->{component} = $component
2605                      if $component;
2606                    return $hdlr_pkg->$method(@_);
2607                };
2608            }
2609            else {
2610                return sub {
2611                    eval "# line " . __LINE__ . " " . __FILE__ . "\nrequire $hdlr_pkg;"
2612                      or Carp::confess(
2613                        "failed loading package $hdlr_pkg for routine $name: $@");
2614                    my $mt_inst = MT->instance;
2615                    local $mt_inst->{component} = $component
2616                      if $component;
2617                    no strict 'refs';
2618                    my $hdlr = \&$name;
2619                    use strict 'refs';
2620                    return $hdlr->(@_);
2621                };
2622            }
2623        }
2624        else {
2625            eval "# line " . __LINE__ . " " . __FILE__ . "\nrequire $hdlr_pkg;"
2626              or Carp::confess(
2627                "failed loading package $hdlr_pkg for routine $name: $@");
2628        }
2629    }
2630    if ($method) {
2631        $code = sub {
2632            my $mt_inst = MT->instance;
2633            local $mt_inst->{component} = $component
2634              if $component;
2635            return $hdlr_pkg->$method(@_);
2636        };
2637    }
2638    else {
2639        if ($component) {
2640            $code = sub {
2641                no strict 'refs';
2642                my $hdlr = (
2643                    defined &$name ? \&$name
2644                    : ( $pkg->can( 'AUTOLOAD' ) ? \&$name
2645                        : undef )
2646                );
2647                use strict 'refs';
2648                if ($hdlr) {
2649                    my $mt_inst = MT->instance;
2650                    local $mt_inst->{component} = $component
2651                      if $component;
2652                    return $hdlr->(@_);
2653                }
2654                return undef;
2655              }
2656        }
2657        else {
2658            no strict 'refs';
2659            $code =
2660              (
2661                defined &$name
2662                ? \&$name
2663                : ( $hdlr_pkg->can( 'AUTOLOAD' ) ? \&$name : undef )
2664              );
2665        }
2666    }
2667    return $code;
2668}
2669
2670sub help_url {
2671    my $pkg = shift;
2672    my ( $append ) = @_;
2673
2674    my $url = $pkg->config->HelpURL;
2675    return $url if defined $url;
2676    $url = $pkg->translate('http://www.movabletype.org/documentation/');
2677    if ( $append ) {
2678        $url .= $append;
2679    }
2680    $url;
2681}
2682
2683sub register_refresh_cache_event {
2684    my $pkg = shift;
2685    my ($callback) = @_;
2686    return unless $callback;
2687
2688    MT->_register_core_callbacks({
2689        "$callback" => \&refresh_cache,
2690    });
2691}
2692
2693sub refresh_cache {
2694    my ($cb, %args) = @_;
2695
2696    require MT::Cache::Negotiate;
2697    my $cache_driver = MT::Cache::Negotiate->new();
2698    return unless $cache_driver;
2699
2700    $cache_driver->flush_all();
2701}
2702
2703sub DESTROY {
2704    # save_config here so not to miss any dirty config change to persist
2705    # particulary for those which does not construct MT::App.
2706    $_[0]->config->save_config();
2707}
2708
27091;
2710
2711__END__
2712
2713=head1 NAME
2714
2715MT - Movable Type
2716
2717=head1 SYNOPSIS
2718
2719    use MT;
2720    my $mt = MT->new;
2721    $mt->rebuild(BlogID => 1)
2722        or die $mt->errstr;
2723
2724=head1 DESCRIPTION
2725
2726The I<MT> class is the main high-level rebuilding/pinging interface in the
2727Movable Type library. It handles all rebuilding operations. It does B<not>
2728handle any of the application functionality--for that, look to I<MT::App> and
2729I<MT::App::CMS>, both of which subclass I<MT> to handle application requests.
2730
2731=head1 PLUGIN APPLICATIONS
2732
2733At any given time, the user of the Movable Type platform is
2734interacting with either the core Movable Type application, or a plugin
2735application (or "sub-application").
2736
2737A plugin application is a plugin with a user interface that inherits
2738functionality from Movable Type, and appears to the user as a
2739component of Movable Type. A plugin application typically has its own
2740templates displaying its own special features; but it inherits some
2741templates from Movable Type, such as the navigation chrome and error
2742pages.
2743
2744=head2 The MT Root and the Application Root
2745
2746To locate assets of the core Movable Type application and any plugin
2747applications, the platform uses two directory paths, C<mt_dir> and
2748C<app_dir>. These paths are returned by the MT class methods with the
2749same names, and some other methods return derivatives of these paths.
2750
2751Conceptually, mt_dir is the root of the Movable Type installation, and
2752app_dir is the root of the "currently running application", which
2753might be Movable Type or a plugin application. It is important to
2754understand the distinction between these two values and what each is
2755used for.
2756
2757The I<mt_dir> is the absolute path to the directory where MT itself is
2758located. Most importantly, the MT configuration file and the CGI scripts that
2759bootstrap an MT request are found here. This directory is also the
2760default base path under which MT's core templates are found (but this
2761can be overridden using the I<TemplatePath> configuration setting).
2762
2763Likewise, the I<app_dir> is the directory where the "current"
2764application's assets are rooted. The platform will search for
2765application templates underneath the I<app_dir>, but this search also
2766searches underneath the I<mt_dir>, allowing the application to make
2767use of core headers, footers, error pages, and possibly other
2768templates.
2769
2770In order for this to be useful, the plugin's templates and
2771code should all be located underneath the same directory. The relative
2772path from the I<app_dir> to the application's templates is
2773configurable. For details on how to indicate the location of your
2774plugin's templates, see L<MT::App>.
2775
2776=head2 Finding the Root Paths
2777
2778When a plugin application initializes its own application class (a
2779subclass of MT::App), the I<mt_dir> should be discovered and passed
2780constructor. This comes either from the C<Directory> parameter or the
2781C<Config> parameter.
2782
2783Since plugins are loaded from a descendent of the MT root directory,
2784the plugin bootstrap code can discover the MT configuration file (and thus
2785the MT root directory) by traversing the filesystem; the absolute path
2786to that file can be passed as the C<Config> parameter to
2787MT::App::new. Working code to do this can be found in the
2788examples/plugins/mirror/mt-mirror.cgi file.
2789
2790The I<app_dir>, on the other hand, always derives from the location of
2791the currently-running program, so it typically does not need to be
2792specified.
2793
2794=head1 USAGE
2795
2796I<MT> has the following interface. On failure, all methods return C<undef>
2797and set the I<errstr> for the object or class (depending on whether the
2798method is an object or class method, respectively); look below at the section
2799L<ERROR HANDLING> for more information.
2800
2801=head2 MT->new( %args )
2802
2803Constructs a new I<MT> instance and returns that object. Returns C<undef>
2804on failure.
2805
2806I<new> will also read your MT configuration file (provided that it can find it--if
2807you find that it can't, take a look at the I<Config> directive, below). It
2808will also initialize the chosen object driver; the default is the C<DBM>
2809object driver.
2810
2811I<%args> can contain:
2812
2813=over 4
2814
2815=item * Config
2816
2817Path to the MT configuration file.
2818
2819If you do not specify a path, I<MT> will try to find your MT configuration file
2820in the current working directory.
2821
2822=item * Directory
2823
2824Path to the MT home directory.
2825
2826If you do not specify a path, I<MT> will try to find the MT directory using
2827the discovered path of the MT configuration file.
2828
2829=back
2830
2831=head2 $mt->init
2832
2833Initializes the Movable Type instance, including registration of basic
2834resources and callbacks. This method also invokes the C<init_config>
2835and C<init_plugins> methods.
2836
2837=head2 MT->instance
2838
2839MT and all it's subclasses are now singleton classes, meaning you can only
2840have one instance per package. MT->instance() returns the active instance.
2841MT->new() is now an alias to instance_of.
2842
2843=head2 $class->instance_of
2844
2845Returns the singleton instance of the MT subclass identified by C<$class>.
2846
2847=head2 $class->construct
2848
2849Constructs a new instance of the MT subclass identified by C<$class>.
2850
2851=head2 MT->set_instance
2852
2853Assigns the active MT instance object. This value is returned when
2854C<MT-E<gt>instance> is invoked.
2855
2856=head2 $mt->find_config($params)
2857
2858Handles the discovery of the MT configuration file. The path and filename
2859for the configuration file is returned as the result. The C<$params>
2860parameter is a reference to the hash of settings passed to the MT
2861constructor.
2862
2863=head2 $mt->init_config($params)
2864
2865Reads the MT configuration settingss from the MT configuration file
2866and settings from database (L<MT::Config>).
2867
2868The C<$params> parameter is a reference to the hash of settings passed to
2869the MT constructor.
2870
2871=head2 $mt->init_plugins
2872
2873Loads any discoverable plugins that are available. This is called from
2874the C<init> method, after the C<init_config> method has loaded the
2875configuration settings.
2876
2877=head2 $mt->init_tasks
2878
2879Registers the standard set of periodic tasks that Movable Type provides
2880and then invokes the C<init_tasks> method for each available plugin.
2881
2882=head2 MT->run_tasks
2883
2884Initializes the tasks, running C<init_tasks> and invokes the task system
2885through L<MT::TaskMgr> to run any registered tasks that are pending
2886execution. See L<MT::TaskMgr> for further documentation.
2887
2888=head2 MT->unplug
2889
2890Removes the global reference to the MT instance.
2891
2892=head2 MT::log( $message ) or $mt->log( $message )
2893
2894Adds an entry to the application's log table. Also writes message to
2895STDERR which is typically routed to the web server's error log.
2896
2897=head2 $mt->server_path, $mt->mt_dir
2898
2899Both of these methods return the physical file path to the directory
2900that is the home of the MT installation. This would be the value of
2901the 'Directory' parameter given in the MT constructor, or would be
2902determined based on the path of the configuration file.
2903
2904=head2 $mt->app_dir
2905
2906Returns the physical file path to the active application directory. This
2907is determined by the directory of the active script.
2908
2909=head2 $mt->config_dir
2910
2911Returns the path to the MT configuration file.
2912
2913=head2 $mt->config([$setting[, $value]])
2914
2915This method is used to get and set configuration settings. When called
2916without any parameters, it returns the active MT::ConfigMgr instance
2917used by the application.
2918
2919Specifying the C<$setting> parameter will return the value for that setting.
2920When passing the C<$value> parameter, this will update the config object,
2921assigning that value for the named C<$setting>.
2922
2923=head2 $mt->user_class
2924
2925Returns the package name for the class used for user authentication.
2926This is typically L<MT::Author>.
2927
2928=head2 $mt->request([$element[,$data]])
2929
2930The request method provides a request-scoped storage object. It is an
2931access interface for the L<MT::Request> package. Calling without any
2932parameters will return the L<MT::Request> instance.
2933
2934When called with the C<$element> parameter, the data stored for that
2935element is returned (or undef, if it didn't exist). When called with
2936the C<$data> parameter, it will store the data into the specified
2937element in the request object.
2938
2939All values placed in the request object are lost at the end of the
2940request. If the running application is not a web-based application,
2941the request object exists for the lifetime of the process and is
2942released when the process ends.
2943
2944See the L<MT::Request> package for more information.
2945
2946=head2 MT->new_ua
2947
2948Returns a new L<LWP::UserAgent> instance that is configured according to the
2949Movable Type configuration settings (specifically C<HTTPInterface>, C<HTTPTimeout>, C<HTTPProxy> and C<HTTPNoProxy>). The agent string is set
2950to "MovableType/(version)" and is also limited to receiving a response of
2951100,000 bytes by default (you can override this by using the 'max_size'
2952method on the returned instance). Using this method is recommended for
2953any HTTP requests issued by Movable Type since it uses the MT configuration
2954settings to prepare the UserAgent object.
2955
2956=head2 $mt->ping( %args )
2957
2958Sends all configured XML-RPC pings as a way of notifying other community
2959sites that your blog has been updated.
2960
2961I<%args> can contain:
2962
2963=over 4
2964
2965=item * Blog
2966
2967An I<MT::Blog> object corresponding to the blog for which you would like to
2968send the pings.
2969
2970Either this or C<BlogID> is required.
2971
2972=item * BlogID
2973
2974The ID of the blog for which you would like to send the pings.
2975
2976Either this or C<Blog> is required.
2977
2978=back
2979
2980=head2 $mt->ping_and_save( %args )
2981
2982Handles the task of issuing any pending ping operations for a given
2983entry and then saving that entry back to the database.
2984
2985The I<%args> hash should contain an element named C<Entry> that is a
2986reference to a L<MT::Entry> object.
2987
2988=head2 $mt->needs_ping(%param)
2989
2990Returns a list of URLs that have not been pinged for a given entry. Named
2991parameters for this method are:
2992
2993=over 4
2994
2995=item Entry
2996
2997The L<MT::Entry> object to examine.
2998
2999=item Blog
3000
3001The L<MT::Blog> object that is the parent of the entry given.
3002
3003=back
3004
3005The return value is an array reference of URLs that have not been pinged
3006for the given entry.
3007
3008An empty list is returned for entries that have a non 'RELEASE' status.
3009
3010=head2 $mt->update_ping_list($blog)
3011
3012Returns a list of URLs for ping services that have been configured to
3013be notified when posting new entries.
3014
3015=head2 $mt->set_language($tag)
3016
3017Loads the localization plugin for the language specified by I<$tag>, which
3018should be a valid and supported language tag--see I<supported_languages> to
3019obtain a list of supported languages.
3020
3021The language is set on a global level, and affects error messages and all
3022text in the administration system.
3023
3024This method can be called as either a class method or an object method; in
3025other words,
3026
3027    MT->set_language($tag)
3028
3029will also work. However, the setting will still be global--it will not be
3030specified to the I<$mt> object.
3031
3032The default setting--set when I<MT::new> is called--is U.S. English. If a
3033I<DefaultLanguage> is set in the MT configuration file, the default is then
3034set to that language.
3035
3036=head2 MT->translate($str[, $param, ...])
3037
3038Translates I<$str> into the currently-set language (set by I<set_language>),
3039and returns the translated string. Any parameters following I<$str> are
3040passed through to the C<maketext> method of the active localization module.
3041
3042=head2 MT->translate_templatized($str)
3043
3044Translates a string that has embedded E<lt>MT_TRANSE<gt> tags. These
3045tags identify the portions of the string that require localization.
3046Each tag is processed separately and passed through the MT->translate
3047method. Examples (used in your application's HTML::Template templates):
3048
3049    <p><MT_TRANS phrase="Hello, world"></p>
3050
3051and
3052
3053    <p><MT_TRANS phrase="Hello, [_1]" params="<TMPL_VAR NAME=NAME>"></p>
3054
3055=head2 $mt->trans_error( $str[, $arg1, $arg2] )
3056
3057Translates I<$str> into the currently-set language (set by I<set_language>),
3058and assigns it as the active error for the MT instance. It returns undef,
3059which is the usual return value upon generating an error in the application.
3060So when an error occurs, the typical return result would be:
3061
3062    if ($@) {
3063        return $app->trans_error("An error occurred: [_1]", $@);
3064    }
3065
3066The optional I<$arg1> (and so forth) parameters are passed as parameters to
3067any parameterized error message.
3068
3069=head2 $mt->current_language
3070
3071Returns the language tag for the currently-set language.
3072
3073=head2 MT->supported_languages
3074
3075Returns a reference to an associative array mapping language tags to their
3076proper names. For example:
3077
3078    use MT;
3079    my $langs = MT->supported_languages;
3080    print map { $_ . " => " . $langs->{$_} . "\n" } keys %$langs;
3081
3082=head2 MT->language_handle
3083
3084Returns the active MT::L10N language instance for the active language.
3085
3086=head2 MT->add_plugin($plugin)
3087
3088Adds the plugin described by $plugin to the list of plugins displayed
3089on the welcome page. The argument should be an object of the
3090I<MT::Plugin> class.
3091
3092=head2 MT->all_text_filters
3093
3094Returns a reference to a hash containing the registry of text filters.
3095
3096=head2 MT->apply_text_filters($str, \@filters)
3097
3098Applies the set of filters I<\@filters> to the string I<$str> and returns
3099the result (the filtered string).
3100
3101I<\@filters> should be a reference to an array of filter keynames--these
3102are the short names passed in as the first argument to I<add_text_filter>.
3103I<$str> should be a scalar string to be filtered.
3104
3105If one of the filters listed in I<\@filters> is not found in the list of
3106registered filters (that is, filters added through I<add_text_filter>),
3107it will be skipped silently. Filters are executed in the order in which they
3108appear in I<\@filters>.
3109
3110As it turns out, the I<MT::Entry::text_filters> method returns a reference
3111to the list of text filters to be used for that entry. So, for example, to
3112use this method to apply filters to the main entry text for an entry
3113I<$entry>, you would use
3114
3115    my $out = MT->apply_text_filters($entry->text, $entry->text_filters);
3116
3117=head2 MT->add_callback($meth, $priority, $plugin, $code)
3118
3119Registers a new callback handler for a particular registered callback.
3120
3121The first parameter is the name of the callback method. The second
3122parameter is a priority (a number in the range of 1-10) which will control
3123the order that the handler is executed in relation to other handlers. If
3124two handlers register with the same priority, they will be executed in
3125the order that they registered. The third parameter is a C<MT::Plugin> object
3126reference that is associated with the handler (this parameter is optional).
3127The fourth parameter is a code reference that is invoked to handle the
3128callback. For example:
3129
3130    MT->add_callback('BuildFile', 1, undef, \&rebuild_file_hdlr);
3131
3132The code reference should expect to receive an object of type
3133L<MT::Callback> as its first argument. This object is used to
3134communicate errors to the caller:
3135
3136    sub rebuild_file_hdlr {
3137        my ($cb, ...) = @_;
3138        if (something bad happens) {
3139            return $cb->error("Something bad happened!");
3140        }
3141    }
3142
3143Other parameters to the callback function depend on the callback point.
3144
3145The treatment of the error string depends on the callback point.
3146Typically, either it is ignored or the user's action fails and the
3147error message is displayed.
3148
3149The value returned from this method is the new L<MT::Callback> object.
3150
3151=head2 MT->remove_callback($callback)
3152
3153Removes a callback that was previously registered.
3154
3155=head2 MT->register_callbacks([...])
3156
3157Registers several callbacks simultaneously. Each element in the array
3158parameter given should be a hashref containing these elements: C<name>,
3159C<priority>, C<plugin> and C<code>.
3160
3161=head2 MT->run_callbacks($meth[, $arg1, $arg2, ...])
3162
3163Invokes a particular callback, running any associated callback handlers.
3164
3165The first parameter is the name of the callback to execute. This is one
3166of the global callback methods (see L<Callbacks> section) or can be
3167a class-specific method that includes the package name associated with
3168the callback.
3169
3170The remaining arguments are passed through to any callback handlers that
3171are invoked.
3172
3173For "Filter"-type callbacks, this routine will return a 0 if any of the
3174handlers return a false result. If all handlers return a true result,
3175a value of 1 is returned.
3176
3177Example:
3178
3179    MT->run_callbacks('MyClass::frobnitzes', \@whirlygigs);
3180
3181Which would execute any handlers that registered in this fashion:
3182
3183    MT->add_callback('MyClass::frobnitzes', 4, $plugin, \&frobnitz_hdlr);
3184
3185=head2 MT->run_callback($cb[, $arg1, $arg2, ...])
3186
3187An internal routine used by C<run_callbacks> to invoke a single
3188L<MT::Callback>.
3189
3190=head2 callback_error($str)
3191
3192This routine is used internally by C<MT::Callback> to set any error response
3193that comes from invoking a callback.
3194
3195=head2 callback_errstr
3196
3197This internal routine returns the error response stored using the
3198C<callback_error> routine.
3199
3200=head2 MT->product_code
3201
3202The product code identifying the Movable Type product that is installed.
3203This is either 'MTE' for Movable Type Enterprise or 'MT' for the
3204non-Enterprise product.
3205
3206=head2 MT->product_name
3207
3208The name of the Movable Type product that is installed. This is either
3209'Movable Type Enterprise' or 'Movable Type Publishing Platform'.
3210
3211=head2 MT->product_version
3212
3213The version number of the product. This is different from the C<version_id>
3214and C<version_number> methods as they report the API version information.
3215
3216=head2 MT->version_id
3217
3218Returns the API version of MT (including any beta/alpha designations).
3219
3220=head2 MT->version_number
3221
3222Returns the numeric API version of MT (without any beta/alpha designations).
3223For example, if I<version_id> returned C<2.5b1>, I<version_number> would
3224return C<2.5>.
3225
3226=head2 MT->schema_version
3227
3228Returns the version of the MT database schema.
3229
3230=head2 MT->version_slug
3231
3232Returns a string of text that is appended to emails sent through the
3233C<build_email> method.
3234
3235=head2 $mt->publisher
3236
3237Returns the L<MT::WeblogPublisher> object that is used for managing the
3238MT publishing process. See L<MT::WeblogPublisher> for more information.
3239
3240=head2 $mt->rebuild
3241
3242An alias to L<MT::WeblogPublisher::rebuild>. See L<MT::WeblogPublisher>
3243for documentation of this method.
3244
3245=head2 $mt->rebuild_entry
3246
3247An alias to L<MT::WeblogPublisher::rebuild_entry>. See L<MT::WeblogPublisher>
3248for documentation of this method.
3249
3250=head2 $mt->rebuild_indexes
3251
3252An alias to L<MT::WeblogPublisher::rebuild_indexes>. See
3253L<MT::WeblogPublisher> for documentation of this method.
3254
3255=head2 $mt->build_email($file, $param)
3256
3257Loads a template from the application's 'email' template directory and
3258processes it as a HTML::Template. The C<$param> argument is a hash reference
3259of parameter data for the template. The return value is the output of the
3260template.
3261
3262=head2 MT::get_next_sched_post_for_user($author_id, @blog_ids)
3263
3264This is an internal routine used by L<MT::XMLRPCServer> and the
3265getNextScheduled XMLRPC method to determine the timestamp for the next
3266entry that is scheduled for publishing. The return value is the timestamp
3267in UTC time in the format "YYYY-MM-DDTHH:MM:SSZ".
3268
3269=head1 ERROR HANDLING
3270
3271On an error, all of the above methods return C<undef>, and the error message
3272can be obtained by calling the method I<errstr> on the class or the object
3273(depending on whether the method called was a class method or an instance
3274method).
3275
3276For example, called on a class name:
3277
3278    my $mt = MT->new or die MT->errstr;
3279
3280Or, called on an object:
3281
3282    $mt->rebuild(BlogID => $blog_id)
3283        or die $mt->errstr;
3284
3285=head1 DEBUGGING
3286
3287MT has a package variable C<$MT::DebugMode> which is assigned through
3288your MT configuration file (DebugMode setting). If this is set to
3289any non-zero value, MT applications will display any C<warn>'d
3290statements to a panel that is displayed within the app.
3291
3292The DebugMode is a bit-wise setting and offers the following options:
3293
3294    1 - Display debug messages
3295    2 - Display a stack trace for messages captured
3296    4 - Lists queries issued by Data::ObjectDriver
3297    8 - Reports on MT templates that take more than 1/4 second to build*
3298    128 - Outputs app-level request/response information to STDERR.
3299
3300These can be combined, so if you want to display queries and debug messages,
3301use a DebugMode of 5 for instance.
3302
3303You may also use the local statement to temporarily apply a particular bit,
3304if you want to scope the debug messages you receive to a block of code:
3305
3306    local $MT::DebugMode |= 4;  # show me the queries for the following
3307    my $obj = MT::Entry->load({....});
3308
3309*DebugMode bit 8 actually outputs it's messages to STDERR (which typically
3310is sent to your web server's error log).
3311
3312=head1 CALLBACKS
3313
3314Movable Type has a variety of hook points at which a plugin can attach
3315a callback.
3316
3317In each case, the first parameter is an L<MT::Callback> object which
3318can be used to pass error information back to the caller.
3319
3320The app-level callbacks related to rebuilding are documented
3321in L<MT::WeblogPublisher>. The specific apps document the callbacks
3322which they invoke.
3323
3324=head2 NewUserProvisioning($cb, $user)
3325
3326This callback is invoked when a user is being added to Movable Type.
3327Movable Type itself registers for this callback (with a priority of 5)
3328to provision the user with a new weblog if the system has been configured
3329to do so.
3330
3331=head1 LICENSE
3332
3333The license that applies is the one you agreed to when downloading
3334Movable Type.
3335
3336=head1 AUTHOR & COPYRIGHT
3337
3338Except where otherwise noted, MT is Copyright 2001-2008 Six Apart.
3339All rights reserved.
3340
3341=cut
Note: See TracBrowser for help on using the browser.