Lines 1465-1472
sub GetMarcPrice {
Link Here
|
1465 |
for my $field ( $record->field(@listtags) ) { |
1465 |
for my $field ( $record->field(@listtags) ) { |
1466 |
for my $subfield_value ($field->subfield($subfield)){ |
1466 |
for my $subfield_value ($field->subfield($subfield)){ |
1467 |
#check value |
1467 |
#check value |
1468 |
$subfield_value = MungeMarcPrice( $subfield_value ); |
1468 |
my $rate; |
1469 |
return $subfield_value if ($subfield_value); |
1469 |
($subfield_value,$rate) = MungeMarcPrice( $subfield_value ); |
|
|
1470 |
if ($subfield_value) { |
1471 |
( $subfield_value ) = $subfield_value =~ m/(\d[\d\,\. ]*\d{0,2})/; |
1472 |
# remove comma,dot or space when used as separators from hundreds |
1473 |
$subfield_value =~s/[\,\. ](\d{3})/$1/g; |
1474 |
# convert comma to dot to ensure correct display of decimals if existing |
1475 |
$subfield_value =~s/,/./; |
1476 |
# convert to active currency if necessary |
1477 |
$subfield_value/= $rate if $rate; |
1478 |
return $subfield_value; |
1479 |
} |
1470 |
} |
1480 |
} |
1471 |
} |
1481 |
} |
1472 |
return 0; # no price found |
1482 |
return 0; # no price found |
Lines 1479-1517
Return the best guess at what the actual price is from a price field.
Link Here
|
1479 |
|
1489 |
|
1480 |
sub MungeMarcPrice { |
1490 |
sub MungeMarcPrice { |
1481 |
my ( $price ) = @_; |
1491 |
my ( $price ) = @_; |
1482 |
|
|
|
1483 |
return unless ( $price =~ m/\d/ ); ## No digits means no price. |
1492 |
return unless ( $price =~ m/\d/ ); ## No digits means no price. |
1484 |
|
1493 |
# Look for the currency symbol and the normalized code of the active currency, if it's there, |
1485 |
## Look for the currency symbol of the active currency, if it's there, |
1494 |
my @currencies= C4::Budgets->GetCurrencies(); |
1486 |
## start the price string right after the symbol. This allows us to prefer |
1495 |
my $symbol; |
1487 |
## this native currency price over other currency prices, if possible. |
1496 |
my $isocode; |
1488 |
my $active_currency = C4::Context->dbh->selectrow_hashref( 'SELECT * FROM currency WHERE active = 1', {} ); |
1497 |
my $rate; |
1489 |
my $symbol = quotemeta( $active_currency->{'symbol'} ); |
1498 |
my $localprice; |
1490 |
if ( $price =~ m/$symbol/ ) { |
1499 |
my @altercurrencies; |
1491 |
my @parts = split(/$symbol/, $price ); |
1500 |
foreach my $cur ( @currencies ) { |
1492 |
$price = $parts[1]; |
1501 |
if ( $cur->{'active'} ) { |
1493 |
} |
1502 |
$symbol = $cur->{'symbol'}; |
1494 |
|
1503 |
$isocode = $cur->{'isocode'}; |
1495 |
## Grab the first number in the string ( can use commas or periods for thousands separator and/or decimal separator ) |
1504 |
} else { |
1496 |
( $price ) = $price =~ m/([\d\,\.]+[[\,\.]\d\d]?)/; |
1505 |
push @altercurrencies, {symbol=>$cur->{'symbol'},isocode=>$cur->{'isocode'},rate=>$cur->{'rate'},}; |
1497 |
|
1506 |
} |
1498 |
## Split price into array on periods and commas |
1507 |
} |
1499 |
my @parts = split(/[\,\.]/, $price); |
1508 |
|
1500 |
|
1509 |
if ( $symbol ) { |
1501 |
## If the last grouping of digits is more than 2 characters, assume there is no decimal value and put it back. |
1510 |
my @matches =($price=~ / |
1502 |
my $decimal = pop( @parts ); |
1511 |
\s? |
1503 |
if ( length( $decimal ) > 2 ) { |
1512 |
( # start of capturing parenthesis |
1504 |
push( @parts, $decimal ); |
1513 |
(?: |
1505 |
$decimal = ''; |
1514 |
(?:\p{Sc}|[a-zA-Z]){1,3} # currency sign (unicode propriety) or alphabetical character whitin 1 to 3 occurrences (block 1) |
1506 |
} |
1515 |
|(?:\d+[\p{P}\s]?){1,4} # or else at least one digit followed or not by a punctuation sign or whitespace, all theese within 1 to 3 occurrences (block 2) |
1507 |
|
1516 |
) |
1508 |
$price = join('', @parts ); |
1517 |
\s?\p{Sc}?\s? # followed or not by a whitespace |
1509 |
|
1518 |
(?: |
1510 |
if ( $decimal ) { |
1519 |
(?:\p{Sc}|[a-zA-Z]){1,3} # followed by same block as block 1 |
1511 |
$price .= ".$decimal"; |
1520 |
|(?:\d+[\p{P}\s]?){1,4} # or by same block as block 2 |
|
|
1521 |
) |
1522 |
# |
1523 |
#~ (?:\s[A-Z]{3})? |
1524 |
\s? # followed or not by 3 alphabetical uppercase character (= isocode for price like '3$ USD') |
1525 |
)? # end of capturing parenthesis |
1526 |
(?:\p{P}|\z) # followed by a punctuation sign, a whitespace or by the end of the string |
1527 |
/gx); |
1528 |
|
1529 |
|
1530 |
if ( @matches ) { |
1531 |
foreach ( @matches ) { |
1532 |
$localprice = $_ and last if index($_, $isocode)>=0; |
1533 |
} |
1534 |
if ( !$localprice ) { |
1535 |
foreach ( @matches ) { |
1536 |
$localprice = $_ and last if $_=~ /(^|[^A-Za-z\p{Sc}])\Q$symbol\E([^A-Za-z\p{Sc}]|\z)/; |
1537 |
} |
1538 |
} |
1539 |
if ( !$localprice and @altercurrencies ) { |
1540 |
foreach my $match ( @matches ) { |
1541 |
foreach my $alter ( @altercurrencies ) { |
1542 |
$localprice = $match and $rate=$alter->{rate} and last if index($match, $alter->{isocode})>=0; |
1543 |
my $altsymbol = $alter->{symbol}; |
1544 |
$localprice = $match and $rate=$alter->{rate} and last if $match=~ /(^|[^A-Za-z\p{Sc}])\Q$altsymbol\E([^A-Za-z\p{Sc}]|\z)/; |
1545 |
} |
1546 |
last if $localprice; |
1547 |
} |
1548 |
} |
1549 |
} |
1550 |
$price=$localprice; |
1512 |
} |
1551 |
} |
1513 |
|
1552 |
return ($price,$rate); |
1514 |
return $price; |
|
|
1515 |
} |
1553 |
} |
1516 |
|
1554 |
|
1517 |
|
1555 |
|