rewrite in perl

1 files changed, 126 insertions, 0 deletions

diff --git a/rf.pl b/rf.pl
new file mode 100644
index 0000000..b2fe726
--- /dev/null
+++ b/rf.pl
@@ -0,0 +1,126 @@
+#!/usr/bin/perl
+
+use v5.12;
+use warnings;
+
+# Default configuration
+
+my $format_full = '(%a %y)';
+my $format_extra = '(%y)';
+my $format_list = '%a (%y). %t. %q. %n, %d. %c: %p.';
+
+# Internal variables
+
+my $author_last = 0; # whether the previous reference field was Ra
+my @lines;
+my $i = -1;
+my @refs;
+
+while (<>) {
+	# Formats
+	if (/^\.Ff +(.*)/) { $format_full = $1; next; }
+	if (/^\.Fx +(.*)/) { $format_extra = $1; next; }
+	if (/^\.Fl +(.*)/) { $format_list = $1; next; }
+
+	# Reference definitions
+	if (/^\.R([a-z]) +(.*)/) {
+		my ($fld, $def) = ($1, $2);
+		if ($fld eq 'a') {
+			$i++ if not $author_last;
+			push @lines, ".R! $i";
+			$refs[$i]{$fld} = $def;
+			$author_last = 1;
+			next;
+		} elsif ($fld =~ /[cdnpqtwy]/) {
+			$refs[$i]{$fld} = $def;
+			$author_last = 0;
+			next;
+		}
+	}
+
+	# Non-rf line
+	push @lines, $_;
+}
+
+for (@lines) {
+	# Inline reference
+	if (/^\.R([fx]) +(.*)/) {
+		my ($fld, $def) = ($1, $2);
+		$def =~ s/ ([.,:;\])]) ?([\[(])?$//;
+		my ($suffix, $prefix) = ($1, $2);
+		my $winner = 0;
+		my @words = split /\s/, $def;
+		my @points;
+		for (my $i = 0; $i < scalar @refs; $i++) {
+			$points[$i] = 0 if not defined $points[$i];
+			$points[$i] += 7 if likeness($refs[$i]{a}, @words);
+			$points[$i] += 4 if likeness($refs[$i]{y}, @words);
+			$points[$i] += 1 if likeness($refs[$i]{t}, @words);
+			$points[$i] += 1 if likeness($refs[$i]{q}, @words);
+			$winner = $i if $points[$i] > $points[$winner];
+		}
+		if (not defined $winner) {
+			print STDERR "Reference '$def' could not be resolved.\n";
+			exit 1;
+		}
+		if ($fld eq 'f') {
+			no warnings;
+			print $prefix . fmt($format_full, $winner) . "$suffix\n";
+		} else {
+			no warnings;
+			print $prefix . fmt($format_extra, $winner) . "$suffix\n";
+		}
+		next;
+	}
+
+	# Reference definition
+	if (/^\.R! (\d+)/) {
+		print fmt($format_list, $1) . "\n";
+
+		next;
+	}
+
+	# Non-rf line
+	print "$_";
+}
+
+sub fmt {
+	my ($fmt, $i) = @_;
+	my %ref = %{$refs[$i]};
+	for my $fld (split //, 'acdnpqtwy') {
+		if ($ref{$fld}) {
+			no warnings;
+			my $val = $ref{$fld};
+			$val = fmta($val) if $fld eq 'a';
+			$fmt =~ s/\{(.*?)%$fld(.*?)}/$1$val$3/g;
+			$fmt =~ s/%$fld/$val/g;
+		} else {
+			no warnings;
+			$fmt =~ s/\{(.*?)%$fld(.*?)}//g;
+			$fmt =~ s/[.(]?%$fld[.,:;)]?//g;
+		}
+	}
+	$fmt =~ s/ +/ /g;
+	$fmt =~ s/^ *//;
+	$fmt =~ s/ *$//;
+	return $fmt;
+}
+
+sub fmta {
+	my ($name) = @_;
+	if ($name =~ /(.*?),/) {
+		return $1;
+	} else {
+		$name =~ s/(.*?)\s/$1/;
+		return $name;
+	}
+}
+
+sub likeness {
+	my ($string, @strings) = @_;
+	return 0 if not defined $string;
+	for (@strings) {
+		return 1 if index($string, $_) != -1;
+	}
+	return 0;
+}