Bug 20434: Update UNIMARC framework - auth (TM)
[koha.git] / C4 / Heading / UNIMARC.pm
blob81dafaef839eb570c9a3bc4d75f03ed45f8b4673
1 package C4::Heading::UNIMARC;
3 # Copyright (C) 2011 C & P Bibliography Services
5 # This file is part of Koha.
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.
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.
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>.
20 use 5.010;
21 use strict;
22 use warnings;
23 use MARC::Record;
24 use MARC::Field;
25 use C4::Context;
28 =head1 NAME
30 C4::Heading::UNIMARC
32 =head1 SYNOPSIS
34 use C4::Heading::UNIMARC;
36 =head1 DESCRIPTION
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.
44 =head1 DATA STRUCTURES
46 FIXME - this should be moved to a configuration file.
48 =head2 subdivisions
50 =cut
52 my %subdivisions = (
53 'j' => 'formsubdiv',
54 'x' => 'generalsubdiv',
55 'y' => 'chronologicalsubdiv',
56 'z' => 'geographicsubdiv',
59 my $bib_heading_fields;
61 =head1 METHODS
63 =head2 new
65 my $marc_handler = C4::Heading::UNIMARC->new();
67 =cut
69 sub new {
70 my $class = shift;
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 <> ''"
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',
87 return bless {}, $class;
90 =head2 valid_bib_heading_tag
92 =cut
94 sub valid_bib_heading_tag {
95 my ( $self, $tag ) = @_;
96 return $bib_heading_fields->{$tag};
99 =head2 valid_bib_heading_subfield
101 =cut
103 sub valid_bib_heading_subfield {
104 my $self = shift;
105 my $tag = shift;
106 my $subfield = shift;
108 if ( exists $bib_heading_fields->{$tag} ) {
109 return 1 if ($bib_heading_fields->{$tag}->{subfields} =~ /$subfield/);
111 return 0;
114 =head2 parse_heading
116 =cut
118 sub parse_heading {
119 my ( $self, $field ) = @_;
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'} );
129 return ( $auth_type, undef, $search_heading, $display_heading, 'exact' );
132 =head1 INTERNAL FUNCTIONS
134 =head2 _get_subject_thesaurus
136 =cut
138 sub _get_subject_thesaurus {
139 my $field = shift;
141 my $thesaurus = "notdefined";
142 my $sf2 = $field->subfield('2');
143 $thesaurus = $sf2 if defined($sf2);
145 return $thesaurus;
148 =head2 _get_search_heading
150 =cut
152 sub _get_search_heading {
153 my $field = shift;
154 my $subfields = shift;
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;
169 else {
170 $heading .= " $value";
174 # remove characters that are part of CCL syntax
175 $heading =~ s/[)(=]//g;
177 return $heading;
180 =head2 _get_display_heading
182 =cut
184 sub _get_display_heading {
185 my $field = shift;
186 my $subfields = shift;
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;
200 else {
201 if ( exists $subdivisions{$code} ) {
202 $heading .= "--$value";
204 else {
205 $heading .= " $value";
209 return $heading;
212 =head1 AUTHOR
214 Koha Development Team <http://koha-community.org/>
216 Jared Camins-Esakov <jcamins@cpbibliography.com>
218 =cut