C4/Heading/UNIMARC.pm

   1 package C4::Heading::UNIMARC;
   2
   3 # Copyright (C) 2011 C & P Bibliography Services
   4 #
   5 # This file is part of Koha.
   6 #
   7 # Koha is free software; you can redistribute it and/or modify it
   8 # under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 3 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  19
  20 use 5.010;
  21 use strict;
  22 use warnings;
  23 use MARC::Record;
  24 use MARC::Field;
  25 use C4::Context;
  26
  27
  28 =head1 NAME
  29
  30 C4::Heading::UNIMARC
  31
  32 =head1 SYNOPSIS
  33
  34 use C4::Heading::UNIMARC;
  35
  36 =head1 DESCRIPTION
  37
  38 This is an internal helper class used by
  39 C<C4::Heading> to parse headings data from
  40 UNIMARC records.  Object of this type
  41 do not carry data, instead, they only
  42 dispatch functions.
  43
  44 =head1 DATA STRUCTURES
  45
  46 FIXME - this should be moved to a configuration file.
  47
  48 =head2 subdivisions
  49
  50 =cut
  51
  52 my %subdivisions = (
  53     'j' => 'formsubdiv',
  54     'x' => 'generalsubdiv',
  55     'y' => 'chronologicalsubdiv',
  56     'z' => 'geographicsubdiv',
  57 );
  58
  59 my $bib_heading_fields;
  60
  61 =head1 METHODS
  62
  63 =head2 new
  64
  65   my $marc_handler = C4::Heading::UNIMARC->new();
  66
  67 =cut
  68
  69 sub new {
  70     my $class = shift;
  71
  72     my $dbh = C4::Context->dbh;
  73     my $sth = $dbh->prepare(
  74         "SELECT tagfield, authtypecode
  75          FROM marc_subfield_structure
  76          WHERE frameworkcode = '' AND authtypecode <> ''"
  77     );
  78     $sth->execute();
  79     $bib_heading_fields = {};
  80     while ( my ( $tag, $auth_type ) = $sth->fetchrow ) {
  81         $bib_heading_fields->{$tag} = {
  82             auth_type => $auth_type,
  83             subfields => 'abcdefghjklmnopqrstvxyz',
  84         };
  85     }
  86
  87     return bless {}, $class;
  88 }
  89
  90 =head2 valid_heading_tag
  91
  92 =cut
  93
  94 sub valid_heading_tag {
  95     my ( $self, $tag ) = @_;
  96     return $bib_heading_fields->{$tag};
  97 }
  98
  99 =head2 valid_heading_subfield
 100
 101 =cut
 102
 103 sub valid_heading_subfield {
 104     my $self          = shift;
 105     my $tag           = shift;
 106     my $subfield      = shift;
 107
 108     if ( exists $bib_heading_fields->{$tag} ) {
 109         return 1 if ($bib_heading_fields->{$tag}->{subfields} =~ /$subfield/);
 110     }
 111     return 0;
 112 }
 113
 114 =head2 parse_heading
 115
 116 =cut
 117
 118 sub parse_heading {
 119     my ( $self, $field ) = @_;
 120
 121     my $tag        = $field->tag;
 122     my $field_info = $bib_heading_fields->{$tag};
 123     my $auth_type  = $field_info->{'auth_type'};
 124     my $search_heading =
 125       _get_search_heading( $field, $field_info->{'subfields'} );
 126     my $display_heading =
 127       _get_display_heading( $field, $field_info->{'subfields'} );
 128
 129     return ( $auth_type, undef, $search_heading, $display_heading, 'exact' );
 130 }
 131
 132 =head1 INTERNAL FUNCTIONS
 133
 134 =head2 _get_subject_thesaurus
 135
 136 =cut
 137
 138 sub _get_subject_thesaurus {
 139     my $field = shift;
 140
 141     my $thesaurus = "notdefined";
 142     my $sf2       = $field->subfield('2');
 143     $thesaurus = $sf2 if defined($sf2);
 144
 145     return $thesaurus;
 146 }
 147
 148 =head2 _get_search_heading
 149
 150 =cut
 151
 152 sub _get_search_heading {
 153     my $field     = shift;
 154     my $subfields = shift;
 155
 156     my $heading   = "";
 157     my @subfields = $field->subfields();
 158     my $first     = 1;
 159     for ( my $i = 0 ; $i <= $#subfields ; $i++ ) {
 160         my $code    = $subfields[$i]->[0];
 161         my $code_re = quotemeta $code;
 162         my $value   = $subfields[$i]->[1];
 163         $value =~ s/[-,.:=;!%\/]*$//;
 164         next unless $subfields =~ qr/$code_re/;
 165         if ($first) {
 166             $first   = 0;
 167             $heading = $value;
 168         }
 169         else {
 170             $heading .= " $value";
 171         }
 172     }
 173
 174     # remove characters that are part of CCL syntax
 175     $heading =~ s/[)(=]//g;
 176
 177     return $heading;
 178 }
 179
 180 =head2 _get_display_heading
 181
 182 =cut
 183
 184 sub _get_display_heading {
 185     my $field     = shift;
 186     my $subfields = shift;
 187
 188     my $heading   = "";
 189     my @subfields = $field->subfields();
 190     my $first     = 1;
 191     for ( my $i = 0 ; $i <= $#subfields ; $i++ ) {
 192         my $code    = $subfields[$i]->[0];
 193         my $code_re = quotemeta $code;
 194         my $value   = $subfields[$i]->[1];
 195         next unless $subfields =~ qr/$code_re/;
 196         if ($first) {
 197             $first   = 0;
 198             $heading = $value;
 199         }
 200         else {
 201             if ( exists $subdivisions{$code} ) {
 202                 $heading .= "--$value";
 203             }
 204             else {
 205                 $heading .= " $value";
 206             }
 207         }
 208     }
 209     return $heading;
 210 }
 211
 212 =head1 AUTHOR
 213
 214 Koha Development Team <http://koha-community.org/>
 215
 216 Jared Camins-Esakov <jcamins@cpbibliography.com>
 217
 218 =cut
 219
 220 1;