1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
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;
}
|