rewrite in perl

2 files changed, 126 insertions, 120 deletions

diff --git a/rf.c b/rf.c
deleted file mode 100644
index 6067373..0000000
--- a/rf.c
+++ /dev/null
@@ -1,120 +0,0 @@
-#include <ctype.h>
-#include <err.h>
-#include <stdbool.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-#include <unistd.h>
-
-#define DEFMAX 300
-
-struct ref {
-	char *a;
-	char *y;
-	char *t;
-	char *q;
-	char *d;
-	char *c;
-	char *p;
-	char *w;
-};
-
-char format_extra[DEFMAX+1];
-char format_full[DEFMAX+1];
-char format_list[DEFMAX+1];
-int refs_s;
-struct ref *refs;
-
-void record(char *dest) {
-	char c;
-	int i;
-	i = 0;
-	while (read(STDIN_FILENO, &c, 1) != 0 && isspace(c))
-		;
-	while (read(STDIN_FILENO, &c, 1) != 0)
-		dest[i++] = c;
-	dest[i] = '\0';
-}
-
-int main() {
-	char c, *buf, last[4];
-	int i, buf_s, ref_i;
-
-	buf_s = 200;
-	buf = malloc((buf_s+1) * sizeof(char));
-	if (buf == NULL) err(1, "malloc");
-
-#define reset(n) do { \
-	strncpy(last, "    ", 4); \
-	i =- n; \
-	buf[i] = '\0'; \
-} while (0)
-
-	i = 0;
-	ref_i = -1;
-
-next:
-	while (read(STDIN_FILENO, &c, 1) != 0) {
-		if (strncmp(last, "\n.F", 3) != 0)
-			goto ref;
-
-		/* record format def */
-		switch (last[4]) {
-		case 'f':
-			record(format_full);
-			break;
-		case 'x':
-			record(format_extra);
-			break;
-		case 'l':
-			record(format_list);
-			break;
-		default:
-			goto add;
-		}
-		reset(3);
-		goto next;
-
-ref:
-		if (strncmp(last, "\n.R", 3) != 0)
-			goto add;
-
-		/* record reference def */
-		switch(last[4]) {
-		case 'a':
-			reset(3);
-			if (ref_i+1 > refs_s) {
-				refs_s += 10;
-				refs = realloc(refs, refs_s*sizeof(struct ref));
-				if (refs == NULL) err(1, "realloc");
-			}
-			ref_i++;
-			refs[ref_i].a = malloc((DEFMAX+1) * sizeof(char));
-			if (refs[ref_i].a == NULL) err(1, "malloc");
-			record(refs[ref_i].a);
-			break;
-		case 'y':
-			break;
-		default:
-			goto add;
-		}
-		reset(3);
-		goto next;
-
-add:
-		/* add to buffer */
-		if (i+1 > buf_s) {
-			buf_s += 100;
-			buf = realloc(buf, (buf_s+1) * sizeof(char));
-			if (buf == NULL) err(1, "realloc");
-		}
-		buf[i++] = c;
-
-		/* keep track of last 4 characters */
-		if (i <= 4) last[i] = c;
-		else {
-			memmove(last, last+1, 3);
-			last[3] = c;
-		}
-	}
-}
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;
+}