diff options
Diffstat (limited to 'rf.pl')
| -rw-r--r-- | rf.pl | 126 |
1 files changed, 126 insertions, 0 deletions
@@ -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; +} |