blib/lib/Reference/Field/Author.pm

   1 # This module is part of da_reference, and is released under the terms
   2 # of the GPL version 2, or any later version, at your option. See the
   3 # file README and COPYING for more information.
   4
   5 # Copyright 2003, 2004 by Don Armstrong <don@donarmstrong.com>.
   6 # $Id: Author.pm 42 2009-03-20 06:29:46Z don $
   7
   8 package Reference::Field::Author;
   9
  10 =head1 NAME
  11
  12 Reference::Field::Author --
  13
  14 =head1 SYNOPSIS
  15
  16
  17 =head1 DESCRIPTION
  18
  19
  20 =head1 TODO
  21
  22 XXX Allow the corresponding author to be set explicitely
  23
  24 XXX To do this, we need to break away from using the author field as
  25 an arrayref, and instead use a hashref with the author fields, and a
  26 specific corresponding author setting. [This should probaly be de
  27 riguer for other fields as well.]
  28
  29 =head1 BUGS
  30
  31 None known.
  32
  33 =cut
  34
  35
  36 use strict;
  37 use vars qw($REVISION $DEBUG);
  38
  39 use NEXT;
  40 use Params::Validate qw(:types validate_with);
  41
  42 BEGIN{
  43      ($REVISION) = q$LastChangedRevision: 42 $ =~ /\$LastChangedRevision:\s+([^\s+])/;
  44      $DEBUG = 0 unless defined $DEBUG;
  45 }
  46
  47
  48 =head2 author
  49
  50 =head3 Usage
  51
  52
  53
  54 =head3 Function
  55
  56 =head3 Returns
  57
  58 =head3 Args
  59
  60 =cut
  61
  62 sub author{
  63      my $self = shift;
  64      my %params;
  65      if (scalar(@_) == 1) {
  66           $params{author} = shift;
  67           $params{output} = 'scalar';
  68           $params{add_author} = 0;
  69           $params{del_author} = 0;
  70      }
  71      else {
  72           %params = validate_with(params => \@_,
  73                                   spec   => {author => {type     => ARRAYREF|SCALAR|HASHREF,
  74                                                         optional => 1,
  75                                                        },
  76                                              add_author => {type    => BOOLEAN,
  77                                                             default => 0,
  78                                                            },
  79                                              del_author => {type    => BOOLEAN,
  80                                                             default => 0,
  81                                                            },
  82                                              output => {default => 'scalar',
  83                                                         type    => SCALAR,
  84                                                        },
  85                                             },
  86                                  );
  87      }
  88      # Update author according to the passed information
  89      if (defined $params{author}) {
  90                $self->{reference}->{author} = {authors              => [],
  91                                                first_author         => 0,
  92                                                corresponding_author => -1,
  93                                               } unless $params{add_author};
  94           # We can't handle things like Smith, Jones, Paul, Rue; for
  95           # obvious reasons. If you must do something so broken, you
  96           # have to go Smith, Jones; Paul, Rue; or Smith, Jones and
  97           # Paul, Rue.
  98           if (not ref($params{author}) and ($params{author} =~ /\sand\,?\s/ or $params{author} =~ /\w\;\s/)) {
  99                $params{author} = [grep /\w/, split (/\s*and,?\s*|\;\s*/,$params{author})];
 100           }
 101           $params{author} = [$params{author}] unless ref($params{author}) eq 'ARRAY';
 102           foreach my $author (@{$params{author}}) {
 103                my $author_info = _parse_author($author);
 104                if (not $params{del_author}) {
 105                     push @{$self->{reference}{author}{authors}},$author_info;
 106                }
 107                else {
 108                     _delete_author($author_info,$author->{reference}{author}{authors});
 109                }
 110           }
 111      }
 112
 113      local $_ = $params{output};
 114      if (/bibtex/) {
 115           return join(' and ',map {$_->{full}} @{$self->{reference}{author}{authors}});
 116      }
 117       else {
 118            return join(', ',map {$_->{full}} @{$self->{reference}{author}{authors}});
 119      }
 120
 121 }
 122
 123 =head2 corresponding_author
 124
 125      my $corresponding_author = $ref->corresponding_author;
 126
 127 Returns the corresponding author (the last author listed.)
 128
 129 =cut
 130
 131 sub corresponding_author{
 132      my $self = shift;
 133
 134      my %params = validate_with(params => \@_,
 135                                 spec   => {output => {default => 'scalar',
 136                                                       type    => SCALAR,
 137                                                      },
 138                                           },
 139                                );
 140      local $_ = $params{output};
 141      if (/bibtex/) {
 142           return $self->{reference}{author}{authors}[$self->{reference}{author}{corresponding_author}]{full};
 143      }
 144      elsif (/last/) {
 145          return $self->{reference}{author}{authors}[$self->{reference}{author}{corresponding_author}]{last};
 146      }
 147      else {
 148           return $self->{reference}{author}{authors}[$self->{reference}{author}{corresponding_author}]{full};
 149      }
 150 }
 151
 152 =head2 first_author
 153
 154      my $first_author = $ref->first_author;
 155
 156 Returns the first author (primary author.)
 157
 158 =cut
 159
 160 sub first_author{
 161      my $self = shift;
 162      my %params = validate_with(params => \@_,
 163                                 spec   => {output => {default => 'scalar',
 164                                                       type    => SCALAR,
 165                                                      },
 166                                           },
 167                                );
 168      local $_ = $params{output};
 169      if (/bibtex/) {
 170           return $self->{reference}{author}{authors}[$self->{reference}{author}{first_author}]{full} || '';
 171      }
 172      elsif (/last/) {
 173          return $self->{reference}{author}{authors}[$self->{reference}{author}{first_author}]{last};
 174      }
 175      else {
 176           return $self->{reference}{author}{authors}[$self->{reference}{author}{first_author}]{full} || '';
 177      }
 178 }
 179
 180
 181 =head2 _parse_author
 182
 183      my $author_info = _parse_author($author);
 184
 185 Parses the author and returns an author record.
 186
 187 Author record
 188
 189 The author can be specified in a few different ways:
 190
 191 =over
 192
 193 =item SCALAR Author Name
 194
 195 =over
 196
 197 =item SMITH John W.
 198
 199 =item Smith JW
 200
 201 =item John W. Smith
 202
 203 =item John Wilkenson Smith
 204
 205 =item HASHREF Author structure
 206
 207 =item ARRAYREF Author Name
 208
 209 =back
 210
 211 In these cases, the author's name should be parsed appropriately. [XXX
 212 Needs to be extended to handle Smith, John W. appropriately.]
 213
 214
 215 =cut
 216
 217 sub _parse_author($){
 218      my ($author) = @_;
 219
 220      warn "Undefined author" and return undef if not defined $author;
 221
 222      # the author information
 223      my %au = ();
 224      if (not ref($author)) {
 225           # UGH. Try to figure out the author.
 226           if ($author =~ /^\s*([A-Z]+)\s+([\w\s]+?)(?:\s*([A-Z])\.)?\s*$/) { # SMITH John W.
 227                $au{first} = ucfirst(lc($2)) || '';
 228                $au{last} = ucfirst(lc($1)) || '';
 229                $au{middle} = $3 || '';
 230                $au{initials} = (($au{first} ne '')?uc(substr($au{first},0,1)):'') .
 231                     (($au{middle} ne '')?uc(substr($au{middle},0,1)):'');
 232                $au{full} = join(' ',grep /\w/,($au{first},$au{middle},$au{last}));
 233           }
 234           elsif ($author =~ /^\s*([A-Z][\w\s]*?)\s+([A-Z]+)\s*$/) { # Smith JW
 235                $au{first} = $2 || '';
 236                $au{middle} = '';
 237                if (length $au{first} > 1) {
 238                     $au{middle} = substr($au{first},1);
 239                     $au{first} = substr($au{first},0,1);
 240                }
 241                $au{last} = $1;
 242                $au{initials} = $2;
 243                $au{full} = join(' ',grep /\w/, ($au{first},$au{middle},$au{last}))
 244           }
 245           elsif ($author =~ /^\s*([A-Z][\w]*?)\s+(?:([A-Z])\.|([A-Z][\w\s]*?)\s+)?\s*([A-Z][\w]*)\s*$/){ # John W. Smith or John Wilkinson Smith
 246                $au{first} = $1;
 247                $au{middle} = $2 || $3 || '';
 248                $au{last} = $4;
 249                $au{full} = join(' ',grep /\w/, ($au{first},$au{middle},$au{last}));
 250           }
 251           # XXX Handle Smith, John Wilkinson; Smith, JW; and Smith, John W.
 252           else {
 253                warn "Couldn't handle author $author";
 254                $au{full} = $author;
 255           }
 256      }
 257      elsif (ref $author eq 'ARRAY') {
 258           warn "Author was empty" unless scalar @{$author};
 259           $au{full} = join(' ',grep /\w/, @{$author});
 260           $au{last} = $author->[-1];
 261           $au{first} = $author->[0] if scalar @{$author} > 1;
 262           $au{middle} = join(' ',grep /\w/,@{$author}[1..($#{$author}-1)]) if scalar @{$author} > 2;
 263           $au{initials} = (($au{first} ne '')?uc(substr($au{first},0,1)):'') .
 264                (($au{middle} ne '')?uc(substr($au{middle},0,1)):'');
 265      }
 266      elsif (ref $author eq 'HASH') {
 267           foreach my $key (qw(full last middle first initials)) {
 268                $au{$key} = '';
 269                $au{$key} = $author->{$key} if exists $author->{$key} and defined $author->{$key};
 270           }
 271           $au{full} = join(' ',grep /\w/, ($au{first},$au{middle},$au{last})) if $au{full} eq '';
 272           $au{initials} = (($au{first} ne '')?uc(substr($au{first},0,1)):'') .
 273                (($au{middle} ne '')?uc(substr($au{middle},0,1)):'') if $au{initials} eq '';
 274      }
 275      else {
 276           warn "Unknown reference: $author";
 277           return undef;
 278      }
 279      return \%au;
 280 }
 281
 282 =head2 _delete_author
 283
 284
 285
 286
 287 XXX NOT IMPLEMENTED
 288
 289 =cut
 290
 291 sub _delete_author($$){
 292      my ($author_info,$author_list) = @_;
 293
 294      die "NOT IMPLEMENTED";
 295 }
 296
 297
 298 =head2 _init
 299
 300 Called by Reference's new function
 301
 302 Call superclass's _init function [C<$self->NEXT::_init>], sets up the
 303 author list reference.
 304
 305 =cut
 306
 307 sub _init{
 308      my $self = shift;
 309
 310      $self->{reference}->{author} = {authors => [],
 311                                      first_author => 0,
 312                                      corresponding_author => -1,
 313                                     };
 314
 315      $self->NEXT::_init;
 316
 317 }
 318
 319
 320
 321 1;
 322
 323
 324 __END__
 325
 326
 327
 328
 329
 330