root/branches/release-36/lib/MT.pm.pre @ 2089

Revision 2089, 105.9 kB (checked in by bsmith, 19 months ago)

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