yaml2plist.pl

#!/usr/bin/env perl

=head1 NAME

yaml2plist.pl - Convert a YAML file to an XML plist file

=head1 SYNOPSIS

perl yaml2plist.pl [<outfile> [<infile>]]

=head1 OPTIONS

=over

=item <outfile>

The name of the plist file to output. The default is F<ModernPerl.tmLanguage>.
The file will be overwritten if it exists.

=item <infile>

The name of the YAML file to convert to plist. The default is
F<ModernPerl.tmLanguage.yaml.ep>. If the file ends in F<.ep>, it will first be
interpreted as L<Extended
Perl|http://mojolicio.us/perldoc/Mojolicious/Guides/Rendering#Embedded_Perl> and
outputted to F<< .<outfile>.yaml >>. Then that new file will be used as
<infile>.

=back

=cut

package ModernPerl::yaml2plist;
use 5.01;
use strict;
use warnings;

use autodie;
use FindBin;
use File::Spec::Functions;
use File::Basename;
use Data::Dumper;

use lib catfile $FindBin::Bin, "inc";
use YAML::XS qw/Load/;
use Mojo::Template;

use subs qw/convert printout badprint/;

my $outfile = shift // "ModernPerl.tmLanguage";
my $infile  = shift // "ModernPerl.tmLanguage.yaml.ep";
my $infilename = basename $infile;
if (@ARGV) {
	say "Usage: $^X $0 [[OUTFILE] INFILE]";
	exit 1;
}

my $yaml;
if ($infile =~ /.ep$/i) {
	my $mt = Mojo::Template->new(auto_escape => 0);
	$yaml = $mt->render_file($infile);
	if (ref $yaml eq "Mojo::Exception") {
		print $yaml->message;
		exit 1;
	}
	my ($name, $dir) = fileparse $outfile;
	my $yamloutfile = catfile $dir, ".$name.yaml";
	printout $yamloutfile, <<YAML, $yaml;
%YAML 1.1
#
# This file was generated automatically by $0 from $infilename.
# DO NOT edit this file directly. Instead use $0 to generate it.
#
YAML
}
else {
	local $/;
	open my $in, "<", $infile;
	$yaml = <$in>;
	close $in;
}

# search for some common mistakes
while ($yaml =~
	m{
		\G (?s:.*?) ^
		(
			(\h+) \w+\h*:\h+ ([|>]) (-?) .*\n

				\2\h+ (\(\? [a-z]*x[a-z-]* \))? .*\n

			(?: \2\h+ .*\n )*
		)
	}gmx
) {
	my ($lines, $taker, $minus, $x) = ($1, $3, $4, $5);
	my $multiline = $lines =~ /(?:.*\n){3}/;

	my $bad;
	if ($multiline and !$x and $taker eq "|") {
		$bad = "Can't multiline non x";
	}
	if ($multiline and $taker eq ">" and $x) {
		$bad = "Can't > with multiline x because you can't use comments";
	}
	if ($multiline and $x and $minus) {
		$bad = "Multiline x looks better without -";
	}
	if (!$minus and !$multiline) {
		$bad = "Probably should be using -";
	}
	if ($bad) {
		say $bad;
		badprint $lines;
	}
}

my ($tree) = Load $yaml;
my $xml = convert $tree, 1;
printout $outfile, <<XML, $xml, "</plist>\n";
<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE plist PUBLIC "-//Apple Computer//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
<!--
This file was generated automatically by $0 from $infilename.
DO NOT edit this file directly. Instead, use $0 to generate it.
-->
<plist version="1.0">
XML

sub convert {
	my $item = shift;
	my $level = shift;
	my $indent = "\t" x $level;
	my $a = $indent;

	if (!ref $item) {
		my $tag = shift;
		if (!defined $tag) {
			badprint "no tag: " . Data::Dumper->Dump([$item], ["value"]);
			return "";
		}

		$item //= '';
		$item =~ s/(?:^|\G)\ {4}/\t/gm; # convert indentation to tabs
		$item =~ s/(?<=\n)/$indent/g;

		my $orig_item = $item;
		$item =~ s/&/&amp;/g;
		$item =~ s/</&lt;/g;
		$item =~ s/>/&gt;/g;
		# use CDATA unless it costs us more characters than not using it
		if (length $item >= 12 + length $orig_item) {
			$item = "<![CDATA[$orig_item]]>" if $orig_item !~ /]]>/;
		}

		$a .= "<$tag>$item</$tag>";
	}
	elsif (ref $item eq "HASH") {
		$a .= "<dict>\n";
		for my $key (sort keys %$item)
		{
			$a .= convert $key,          $level + 1, "key";
			$a .= convert $item->{$key}, $level + 1, $key eq "applyEndPatternLast" ? "integer" : "string";
		}
		$a .= "$indent</dict>";
	}
	elsif (ref $item eq "ARRAY") {
		$a .= "<array>\n";
		for my $value (@$item) {
			$a .= convert $value, $level + 1, "string";
		}
		$a .= "$indent</array>";
	}
	else {
		badprint "unexpected: " . Data::Dumper->Dump([$item], ["item"]);
		return "";
	}

	return $a . "\n";
}

sub printout {
	my $outfile = shift;
	chmod 0666, $outfile if -f $outfile; # read-write
	open my $out, ">", $outfile;
	binmode $out;
	print $out @_;
	close $out;
	chmod 0444, $outfile; # read only
}

sub badprint {
	state $once = eval "END { exit 1 }"; # exit 1 on END if we ever reach this code
	print @_;
}