Planet Catalyst

#!/usr/bin/perl

use strict;
use warnings;

use lib qw(MT/lib);
use MT::ConfigMgr;

my $file = "MT/mt-config.cgi";

my $mgr = MT::ConfigMgr->instance;
$mgr->read_config_file($file);

my @cfg;
push(@cfg, 'dbi:mysql:' . $mgr->get('database'));
push(@cfg, $mgr->get('dbuser'));
push(@cfg, $mgr->get('dbpassword'));

my $schema = MT::Schema->connect(@cfg);
my $entries = $schema->resultset('MtEntry')->search({
    entry_basename => { LIKE => '%\_%' },
});
while (my $entry = $entries->next) {
    my ($month, $day) = ($entry->entry_authored_on =~ /^(\d+)-(\d+)-/);
    my $base = $entry->entry_basename;
    my $origname = $base . ".html";
    my $filename = sprintf("%04d/%02d/%s.html", $month, $day, $base);

    $base =~ s/_/-/g;
    my $wrong = sprintf("%04d/%02d/%s.html", $month, $day, $base);

    if (-e $wrong && -e $filename) {
        open(my $r, $filename) or die;
        my $data = do { local $/; <$r>; };
        close($r);

        my ($title) = $data =~ m!<title>(.*?)</title>!s;

        warn "$title $filename";
        open(my $fh, "> $wrong") or die;
        printf $fh qq{<html><body>Requested entry <a href="%s">%s</a> has moved.</body></html>\n}, $origname, $title;
        close($fh);
    }
}

package MT::Schema;

use strict;
use warnings;

use base 'DBIx::Class::Schema::Loader';

__PACKAGE__->loader_options(
    relationships => 0,
    debug         => 0,
    components    => [],
);

1;