(Translated by https://www.hiragana.jp/)
#!/usr/bin/perl
# Falls der Webserver das Arbeitsverzeichnis nicht auf das Verzeichnis
# mit den Skripten einstellen kann, die naechste Zeile aktivieren, die
# Ausfuehrung wechselt dann das Verzeichnis.
#BEGIN { ($0 =~ m=^(.*)[/\\][^/\\]+=) && chdir $1 };
# (Siehe aber auch "use lib ..." weiter unten.)
# evb.pl: Populo-Konfiguration fuer die Datenbank evb
# $Id: hansdemo.dt 24654 2012-10-02 16:24:43Z ThB $
# Diese Datei ist ISO-8859-1 -codiert: "ÄÖÜ" (Ae Oe Ue)
# Copyright (c) 1997-2012 Thomas Berger
# This program is free software: you can redistribute it and/or modify
# it under the terms of either
# - the GNU General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
# - or the Artistic License 2.0.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program. If not, see .
#
# You should have received a copy of the Artistic License 2.0 along
# with this program. If not, see .
#
use strict;
# Setzen falls populo.pl/popdebug.pm etc. nicht im aktuellen Verzeichnis:
use lib 'pop-1.2x'; # "." ist Pleonasmus
use vars qw($Pop $LegacyCharset $CanXCode $Robots $Stl %MYSUBS %Defaults %in $Lang $MoreLang $JobContext);
use vars qw($Db $DbIdNSId $DbIdPfx @IdPrefixStrip $BaseDb $RawDb $RealDb $noKlotzSTW $GlobalRestriktion $AutoRestriktion);
use vars qw($Treu $register $logik $trunk $sr $RecnumsMax $RecnumsMaxweight $MaxWeightOnly);
use vars qw($SwitchDbSuffix $WRIPATH $AvantiHost $AvantiPort $AvantiUser $User $AvantiPass $Passwd $DbTime);
# Versionierung: Wert auch als #uSV in Parametern greifbar fuer Tests ("Capabilities")
our $ProtVer = 2; # YOU may under no circumstances change this value!
our($ShowNLR, $ShowSTLSig, $NavLeiste,
$ExtConfig, $ExtConfigFile, $Rebase, $USE_Frames, $USE_Cookies, $FancyButtons, $GraphicButtons, $Plain,
$AdhocCSS, $BgEvenColor, $BgOddColor, @CSSList, %CSSURLS, $SwitchForm, $InitPage,
$ORGNameDrop, $ORGKontakt, $ORGCopyRange, $ORGInstitution, $ORGHomeName,
$ORGHomeURL, $HSAuswLogo, $DbLabel, $DbTitle, $TermIndex, $TermIndexSearch, $TermSearch, $ButtonBrowse,
$PageHeader, $PageFooter, $LogoLeft, $LogoMiddle, $LogoRight,
$MainBodyAttrs, $AuswBodyAttrs, $HelpBodyAttrs, $ModifyPageTitle, %VarTexts,
$StaticHSPath, $StaticHSAusw, $StaticHSIntro, $StaticHSUsage, $StaticHSBanner, $StaticHSHelpDir,
$StaticPath, $ImgPath, $CSSPath, $ClnPath, $SeeAPath,
$FrameBannerName, $FrameMainName, $FrameLeftName, $FrameHelpName,
$HSSubTextsDir, $HSAuswName, $HSUsageName, $HSIntroName, $HSBannerName,
$PathInfo,
%Features, @FeaturesActive, %SeeAlsoServices, @SeeAlsoServicesUsed, %StupidGNDLinks, @StupidGNDLinksUsed,
%SeeAFormats, %SeeADescription, %SeeAExamples,
@SeeAFormatsAdvertised, @SeeADescriptionElements, @SeeAExampleList,
$AbbrRE, %Abbrs,
);
# Setzungen aus separater Datei evb.conf duerfen wirken!
$ExtConfig = 1;
%Features = (
'#Labels#' => ['Value'],
# "Features" der Oberflaeche (Tokens, die an Parameterdateien durchgereicht werden)
# Die Liste der Labels (genauer: solche ohne ":") wird von PrepDownload an Avanti
# als Anwendervariable #uFT durchgereicht.
# Zu jedem Feature muss eine zugehoerige Routine proc vorgehalten
# werden. In dieser Datei vorbereitet:
# 'GNDLink' => [], # Normdaten-Portal der DDB
# 'SeeAlsoServer' => [], # SeeAlso/openSearch/unAPI-Service
# 'SeeAlsoClient' => [], # SeeAlso-Client-Funktionalitaet
# 'StupidGNDLinks' => [], # Verlinkungsangebote
# 'PermaLink' => [], # Persistenter Link auf die aktuelle Aufnahme
# 'BestForm' => [], # Generisches Bestellformular
# Konfiguration durch Eintragen sinnvoller Werte in der .conf-Datei, Beispiele
# in hansgenerisch.conf und hansdemo.conf
);
#### PND-Verlinkungen, bekannte URLs:
# siehe auch http://www.ndb.badw-muenchen.de/eb_pnd.htm
# NLV: Hat BEACON-Datei
# RI: Hat BEACON-Datei
# VD16: Hat BEACON-Datei
# Kalliope: Hat (veraltete) BEACON-Datei
%StupidGNDLinks = (
'#Labels#' => ['ServiceURL', 'Linktext', 'Tooltip', 'Format'], # Format-Default: populo_linkbutton, auch moeglich: hans_external
'pnd2lHANNA' => ['http://aleph.onb.ac.at/F?func=find-b&local_base=ONB06&find_code=WRD&request=%s',
"ÖNB-HANNA?", "Nachlass- und Autographenkatalog der Österreichischen Nationalbibliothek"],
'pnd2n2NAH' => ['http://aleph20-prod-acc.obvsg.at/F?CON_LNG=ger&func=find-b&local_base=acc05&find_code=WRD&request=%s',
"ÖVK-NAH?", "Österreichischer Verbundkatalog für Nachlässe, Autographen und Handschriften"],
'pnd2n2NLV' => ['http://aleph20-prod-acc.obvsg.at/F?CON_LNG=ger&func=find-b&local_base=nlv&find_code=WRD&request=%s',
"NLV?", "Verzeichnis der künstlerischen, wissenschaftlichen und kulturpolitischen Nachlässe in Österreich"],
'pnd2n1KALLIOPE' => ['http://kalliope-portal.de/cgi-bin/kalliope_pnd.pl?%s',
"Kalliope/ZKA?", "Verbundkatalog Nachl\xe4sse und Autographen der Zentralkartei der Autographen"],
'pnd2x1RI' => ['http://opac.regesta-imperii.de/lang_de/suche.php?qs=%s',
"RI-OPAC?", "Literaturdatenbank der Regesta Imperii"],
'pnd2x2VD16' => ['http://www.gateway-bayern.de/opensearch?rfr_id=lwl.org:wg&res_id=VD16&rft_id=info:pnd/%s',
"VD 16?", "Verzeichnis der im deutschen Sprachbereich erschienenen Drucke des 16. Jahrhunderts (VD 16)"],
);
#### SeeAlso-Client: gaengige Dienste: ####
# vgl. auch http://de.wikipedia.org/wiki/Wikipedia:PND/BEACON
# http://ws.gbv.de/beacon/
# und http://beacon.findbuch.de/
%SeeAlsoServices = (
'#Labels#' => ['ServiceURL', 'Prefix', 'Tooltip',
'Format', 'Filter'], # Tooltip derzeit ungenutzt
'pnd2wpd_de' => ["http://ws.gbv.de/seealso/pnd2wikipedia", 'Wikipedia'], # "Deutschsprachige Wikipedia"
'pnd2vd17' => ["http://ws.gbv.de/seealso/pnd2vd17", ''], # "blabla im VD17"
'pnd2viafmappings' => ["http://ws.gbv.de/seealso/viafmappings", 'Nachweise VIAF'],
'pnd2aks' => ["http://beacon.findbuch.de/seealso/pnd-aks", "Externe Nachweise", '',
"SeeAlsoOL( {'linkTarget':'_blank', 'maxItems':-1} )"],
'pnd2hanszentral' => ["http://beacon.findbuch.de/seealso/hanszentral", "Andere Best\xe4nde", '',
"SeeAlsoUL( {'linkTarget':'_blank', 'maxItems':-1} )", '/hansdemo.gymel.com/'],
'pnd2nlbest' => ["http://beacon.findbuch.de/seealso/pnd-nlbest", "Best\xe4nde in Archiven", '', "SeeAlsoUL({'linkTarget':'_blank'})"],
'pnd2nldocs' => ["http://beacon.findbuch.de/seealso/pnd-nldocs", "Dokumente in Nachl\xe4ssen", '', "SeeAlsoUL({'linkTarget':'_blank'})"],
'pnd2kalliope' => ["http://beacon.findbuch.de/pnd-resolver/kalliope", ''],
'gkd2aks' => ["http://beacon.findbuch.de/seemore/gkd-aks", "Externe Nachweise", '',
"SeeAlsoOL( {'linkTarget':'_blank', 'maxItems':-1} )"],
'gnd2aks-p' => ["http://beacon.findbuch.de/seealso/pnd-aks", "Externe Nachweise", '',
"SeeAlsoOL( {'linkTarget':'_blank', 'maxItems':-1} )"],
'gnd2aks-k' => ["http://beacon.findbuch.de/seemore/gkd-aks", "Externe Nachweise", '',
"SeeAlsoOL( {'linkTarget':'_blank', 'maxItems':-1} )"],
'gnd2nlbest' => ["http://beacon.findbuch.de/seealso/pnd-nlbest", "Best\xe4nde in Archiven", '', "SeeAlsoUL({'linkTarget':'_blank'})"],
'gnd2nldocs' => ["http://beacon.findbuch.de/seealso/pnd-nldocs", "Dokumente in Nachl\xe4ssen", '', "SeeAlsoUL({'linkTarget':'_blank'})"],
);
#### SeeAlso-Server: Vorbereitung (unAPI-Zweig) ####
# Diese Formate sind vorbereitet, werden aber nicht automatisch advertised! (cf. SeeAFormatsAdvertised)
# Formate mit "text/javascript" als "Type" gelangen in die OpenSearchDescription, nur diese
# benoetigen "Template"
# Alle Formate ausser "" gelangen in die unAPI-Formatliste
our %SeeAFormats = (
'#Labels#' => ['Type', 'Docs', 'Template', 'FlexTest', 'DontUse'],
'#Default#' => "",
"" => ['application/xml', 'http://unapi.info/specs/', ""], # unapi format list
'seealso' => ['text/javascript', "http://ws.gbv.de/seealso/",
"/seealso/?format=seealso&id={searchTerms}&callback={seealso:callback?}"],
'opensearchdescription' => ['application/opensearchdescription+xml',
'http://www.opensearch.org/Specifications/OpenSearch/1.1/Draft_4#OpenSearch_description_document',
# "/seealso/?format=opensearchdescription",
],
'mods' => ['application/xml', 'http://www.loc.gov/standards/mods/v3/mods-3-3.xsd',
"/seealso/?format=mods&id={searchTerms}&callback={seealso:callback?}",
'if not #080 var ""', # 'OK' loeschen falls z.B. Normsatz
],
'oai_dc' => ['application/xml', 'http://www.openarchives.org/OAI/2.0/oai_dc.xsd',
"/seealso/?format=oai_dc&id={searchTerms}",
'if not #080 var ""', # 'OK' loeschen falls z.B. Normsatz
],
'hansxml' => ['application/xml', 'http://www.hans-support.de/specs/hansxml/0.7/',
"/seealso/?format=hansxml&id={searchTerms}",
'if #013 var ""', # unzureichender Test auf Sperrvermerk
],
# Zusaetzliche in .conf-Datei angeben, etwa
# 'ris' => ['application/x-Research-Info-Systems', 'http://www.refman.com/support/risformat_intro.asp',
# "/seealso/?format=ris&id={searchTerms}",
# 'if not #331 var ""', # 'OK' loeschen falls z.B. Stammsatz
# ],
# 'json_dc' => ['text/javascript', '',
# "/seealso/?format=json_dc&id={searchTerms}&callback={seealso:callback?}"],
);
$USE_Frames = 0; # Standard: FrameLayout
sub Defaults {
# Die folgenden Setzungen werden nur aktiv, wenn in der .conf-Datei
# nichts gesetzt wird
# Basisverzeichnisse fuer Images, Styles und Scripts etc.
# waren in .conf direkt setzbar oder als Standard-Unterverzeichnisse von dort setzbarem $StaticPath
$ImgPath = ((defined $StaticPath) ? "$StaticPath/images" : '/hansimag' ) unless defined $ImgPath;
$CSSPath = ((defined $StaticPath) ? "$StaticPath/styles" : '/hansstyle' ) unless defined $CSSPath;
$ClnPath = ((defined $StaticPath) ? "$StaticPath/scripts" : '/hansscript' ) unless defined $ClnPath;
$SeeAPath = ((defined $StaticPath) ? "$StaticPath/seealso" : '/hansseealso' ) unless defined $SeeAPath;
# Unterverzeichnisse Hilfetexte und Dual-use-content (Text-Unterverzeichnis als relativer Pfad auf dem Server)
$HSSubTextsDir = 'texts' unless defined $HSSubTextsDir;
# sollen Intro, Auswahl, Hilfe statisch geladen werden?
# (wenn $StaticHSPath gesetzt, dann entspricht das ebenfalls dem "texts"-Unterverzeichnis, jedoch als URL
$StaticHSHelpDir = ($StaticHSPath ? "${StaticHSPath}" : "" ) unless defined $StaticHSHelpDir;
$StaticHSAusw = ($StaticHSPath ? "${StaticHSPath}/${HSAuswName}.htm" : "" ) unless defined $StaticHSAusw;
$StaticHSIntro = ($StaticHSPath ? "${StaticHSPath}/${HSIntroName}.htm" : "" ) unless defined $StaticHSIntro;
$StaticHSUsage = ($StaticHSPath ? "${StaticHSPath}/${HSUsageName}.htm" : "" ) unless defined $StaticHSUsage;
$StaticHSBanner = ($StaticHSPath ? "${StaticHSPath}/${HSBannerName}.htm" : "" ) unless defined $StaticHSBanner;
# Derzeit setzt Populo das Default noch auf 1...
# und wir auch, falls alte Avantis im Einsatz sind.
$LegacyCharset = 0 unless defined $LegacyCharset; # 0: UTF-8 codiert arbeiten
# bessere UTF-8-Umcodierungsmoeglichkeiten ab ca. V29.3,
$CanXCode = 1 unless defined $CanXCode;
# aeltere Populo-Versionen kennen $User / $Passwd anstatt $AvantiUser / $AvantiPass
$User ||= $AvantiUser; $Passwd ||= $AvantiPass;
# die erste 1 zaehlt!
# Deaktivieren: Auf 0 setzen, NICHT auskommentieren
# Effekte mit JavaScript
$FancyButtons = 0 unless defined $FancyButtons;
# Graphische Buttons
$GraphicButtons = 0 unless defined $GraphicButtons;
$Robots = "noindex,nofollow" unless defined $Robots;
# Ueberschriftszeile in hsausw.htm (Frame links)
$DbLabel = 'Autographenkatalog' unless defined $DbLabel;
# Titel = Kurzbenennung im Fensterrahmen, besonders index.htm
$DbTitle = 'Katalog' unless defined $DbTitle;
$ButtonBrowse = ' ? ' unless defined $ButtonBrowse; # "?" vs. "Index"
$TermIndex = 'Register' unless defined $TermIndex; # "Register" vs. "Index"
$TermIndexSearch = 'Registersuche' unless defined $TermIndexSearch; # "Registersuche" vs. "Indexrecherche"
$TermSearch = 'Suche' unless defined $TermSearch; # "Recherche" vs. "Suche"
%VarTexts = (
'#Labels#' => ['PageTitle'],
'#Default#' => "_fallback",
'_fallback' => ["Katalog"],
'acexpand' => ["$TermIndex expandiert"],
'acindex' => ["$TermIndexSearch"],
'allegro' => ["Darstellung $TermSearch"],
'brow' => ["Suchbegriffswahl"],
'cookie' => ["populo: Cookie editieren"],
'kombi' => ["Kombinierte $TermSearch"],
'nlr' => ["Nachlassverzeichnis"],
'noans' => ["Verbindungsausfall"],
'noconn' => ["Keine Verbindung zum Server"],
'noend' => ["Endlosschleife"],
'nognd' => ["Kein interner Normsatz"],
'nojob' => ["Interner Fehler"],
'noquery' => ["Keine Anfrage"],
'noselect' => ["Nichts selektiert"],
'notyet' => ["Server wird gestartet"],
'seea-demoform' => ["SeeAlso test mit HANS"],
'show' => ["Ergebnisanzeige"],
'simple' => ["Stichwortsuche"],
'systematik' => ["Bestandssystematik"],
) unless %VarTexts;
# Parameter fuer die Standard-Fussteile der Templates
$ORGCopyRange = "" unless defined $ORGCopyRange;
$ORGInstitution = '{configure me: $ORGInstitution}' unless defined $ORGInstitution;
$ORGHomeURL = '{configure me: $ORGHomeURL}' unless defined $ORGHomeURL;
$ORGHomeName = '{configure me: $ORGHomeName}' unless defined $ORGHomeName;
$ORGKontakt = '{configure me: $ORGKontakt}' unless defined $ORGKontakt;
$ORGNameDrop = '' unless defined $ORGNameDrop;
# Logo/Navigation oben im Ausw-Frame
unless ( defined $HSAuswLogo ) {
$HSAuswLogo = <<"XxX";
[Home]
XxX
};
# Parameter fuer den Standard-Kopfteil der Templates
# Logos etc.
unless ( defined $LogoLeft ) {
$LogoLeft = <<"XxX";
XxX
};
unless ( defined $LogoMiddle ) {
$LogoMiddle = <<"XxX";
XxX
};
unless ( defined $LogoRight ) {
$LogoRight = <<"XxX";
XxX
};
unless ( defined $PageHeader ) {
$PageHeader = "" unless defined $PageHeader; # "if still undefined"
};
unless ( defined $PageFooter ) {
$PageFooter = "" unless defined $PageFooter;
};
unless ( defined $AdhocCSS ) {
$AdhocCSS = "" unless defined $AdhocCSS;
};
$MainBodyAttrs = qq() unless defined $MainBodyAttrs;
$AuswBodyAttrs = qq() unless defined $AuswBodyAttrs;
$HelpBodyAttrs = qq() unless defined $HelpBodyAttrs;
# Viecherei: Die Farben sind im Stylesheet gesetzt, warum nicht dort aendern...
if ( $BgEvenColor ) {
$AdhocCSS .= <<"XxX"
tr.hansopac_indexrow_even, tr.hansopac_shortrow_even { background-color: $BgEvenColor }
XxX
};
if ( $BgOddColor ) {
$AdhocCSS .= <<"XxX"
tr.hansopac_indexrow_odd, tr.hansopac_shortrow_odd { background-color: $BgOddColor }
XxX
};
# Nachlassregister: Anbieten: 1, nicht Anbieten: 0
$ShowNLR = 0 unless defined $ShowNLR;
# Signaturen in Kurzliste: zeigen: 1, nicht zeigen: 0
$ShowSTLSig = 1 unless defined $ShowSTLSig;
# Blaettern in Kurzlisten: Navigationsleiste im Absatz statt Tabelle mit Buttons
$NavLeiste = (defined &NavLeiste) unless defined $NavLeiste;
# Formatumschaltung unter Vollanzeige: Anbieten: 1, nicht Anbieten: 0
$SwitchForm = 0 unless defined $SwitchForm;
# vgl. auch DefaultJTHook!
$InitPage = "" unless defined $InitPage;
unless ( $Defaults{'JobTyp'} ) {
$Defaults{'JobTyp'} = $USE_Frames ? "start" : ($InitPage || "kombi")};
$FancyButtons = 0 unless $USE_Frames;
# HTML-title-Element (des hoechsten Dokuments) per JavaScript retrospektiv ummodeln
$ModifyPageTitle = "" unless defined $ModifyPageTitle;
## Normalisierung von Identnummern
$DbIdNSId ||= ""; # nicht standardmaessig global eindeutige erzeugen...
unless ( defined $DbIdPfx ) {
($DbIdPfx = $Db) =~ s/\d+$//};
$DbIdPfx =~ s~[:/]*$~:~;
$DbIdPfx =~ s~^[:/]*~~;
@IdPrefixStrip = () unless @IdPrefixStrip;
### Feature-Inits
@FeaturesActive = grep !/^#/, keys %Features; # Damit show.htm nicht TestStrucentry benoetigt
if ( $Features{SeeAlsoServer} ) {
# vgl. auch DefaultJTHook!
unless ( $SeeADescription{'ShortName'} ) {
$SeeADescription{'ShortName'}->[0] = "$Db unconfigured";
$SeeADescription{'SyndicationRight'}->[0] ||= "closed";
}
$SeeADescription{'Description'}->[0] ||= "Resolving Service: Id-Number => several output formats";
@SeeADescriptionElements = grep !/^#/, (sort keys %SeeADescription) unless @SeeADescriptionElements;
@SeeAFormatsAdvertised = qw(seealso opensearchdescription) unless @SeeAFormatsAdvertised;
unless ( %SeeAExamples ) {
%SeeAExamples = ( '#Labels#' => ['Example'], map {$_ => [$_]} @SeeAExampleList )};
@SeeAExampleList = grep !/^#/, (sort keys %SeeAExamples) unless @SeeAExampleList;
};
if ( $Features{SeeAlsoClient} ) {
# Wir nehmen alle vorbereiteten, falls nichts anderes konfiguriert ist
@SeeAlsoServicesUsed = grep !/^#/, (sort keys %SeeAlsoServices) unless @SeeAlsoServicesUsed;
};
if ( $Features{StupidGNDLinks} ) {
# Wir nehmen alle vorbereiteten, falls nichts anderes konfiguriert ist
@StupidGNDLinksUsed = grep !/^#/, (sort keys %StupidGNDLinks) unless @StupidGNDLinksUsed;
};
}
####################################################### Avanti #####
# !!!!
# Die folgenden Setzungen sollten moeglichst in der .conf-Datei vorgenommen werden!
# !!!!
# Avanti-Datenbankname (Default: Der Name dieses Scripts, ohne .pl oder endende Ziffern)
#$RealDb='evb';
# dynamische Setzung (live-Umschaltmoeglichkiet)
# $WRIPATH/current.$SwitchDbSuffix enthaelt Zeile mit
# Datenbankname:numerische Zeit:Datenbankgroesse
#$SwitchDbSuffix = "evb";
#$WRIPATH = "./tmp";
# Werte fuer AVANTI (populo.pl setzt selbst /keine/ Defaults)
$AvantiUser = "";
#$AvantiUser = "opac";
$AvantiPass = "";
#$AvantiPass = "OPAC";
#### Fernzugriff auf Avanti (staerker als die Defaults localhost:4949 in populo.pl)
#$AvantiHost = "127.0.0.1";
#$AvantiPort = 4949;
####################################################### Layout #####
# Die folgenden Setzungen koennen ebenfalls in der .conf-Datei ueberschrieben
# werden
# Namen der Frames
# Frame fuer hsintro und Db
$FrameMainName = "begriff";
# Frame fuer hsausw
$FrameLeftName = "auswahl";
# Frame fuer einzublendende Hilfetexte
$FrameHelpName = "auswahl";
# Frame fuer Optionales Banner (kein Default)
$FrameBannerName = "FrameBannerName_not_configured";
# Namen der in die Frames zu ladenden Grundseiten
$HSBannerName = "$(HSBANNERNAME)";
$HSAuswName = "$(HSAUSWNAME)";
$HSIntroName = "hsintro";
$HSUsageName = "hsintro";
# neu: Liste von externen Stylesheets. Labels bitte nur numerisch!
%CSSURLS = (
'#Labels#' => ['Uri', 'Media'],
10 => ['PO!CSSPath!/hans-opac.css', ""], # externes Stylesheet #2
);
####################################################### Diagnostik #####
use vars qw($Border $Debug @WantDebug $EngRev $pathpraefix);
# kann bei Bedarf aktiviert werden
$Border=0;
# moegliche Parameter: Showjob, Showresult, Params, Envir, Conf, Comm
# ShowSTL, Showcode, Parseval, ShowLoad
$Debug=0; # $$
#@WantDebug = qw(Showjob Showresult Params ShowLoad ShowSTL Query Comm); # $$
$EngRev = 'HANS-OPAC v2.7 $Revision: 24654 $ Build 24-043'." [Protocol $ProtVer]"; # Original Engine Revision
# Job und Ausgabevorlagen in Unterverzeichnissen 'evb_job' oder 'evb_tpl',
# hilfsweise im aktuellen (Populo-/CGI-)Verzeichnis
$pathpraefix = 'evb_job/;evb_tpl/;./';
################################################## Anwendungsparameter #####
our($MaxShowResult, $MaxShowIndex, $MaxCountIndex, $MaxShowBrowse, $MaxCountExpand, $MaxAllowResult,
$MaxShowExpand, $MaxExpandedEntries, $MinIndexSearchAgain, $MaxWriteThrough, $MaxWeightResult);
# Seitengroesse fuer Ergebnisliste
$MaxShowResult = 15;
# Seitengroesse fuer Registerausschnitt
$MaxShowIndex = 15;
# Trefferzahl fuer Registerausschnitte
$MaxCountIndex = 9999;
# Seitengroesse fuer Registerausschnitt beim Browsen
$MaxShowBrowse = 10;
# Trefferzahl fuer Registerausschnitte mit Kurztiteln
$MaxCountExpand = 99;
# Maximale Ergebnismengengroesse
$MaxAllowResult = 999;
# Seitengroesse fuer Registerausschnitt mit Kurztiteln
$MaxShowExpand = 10;
# maximale Anzahl Kurztitel pro Caption
$MaxExpandedEntries = 10;
# Oberhalb dieser Menge soll beim Klicken auf Index-Links eine Kurzliste
# erstellt werden
$MinIndexSearchAgain = 10;
# Unterhalb dieser Menge soll bei kombinierter Suche direkt in die
# Vollanzeige geschaltet werden (1 fuer nie)
$MaxWriteThrough = 6;
################################################### Datenbankparameter #####
# Hat die Datenbank einen Kurztitelindex (.STL)? -> $Stl = Laenge STL-Eintrag
use vars qw($Stl $ParamStl @STLStruktur %STLPositionen %STLexpand %STLsuppresscaption);
# (entspr. Parameter i0 in Indexparameterdatei)
# Hat die Datenbank keinen Kurztitelindex (.STL)? -> $Stl = 0
$Stl = 80;
# Schick: Kurztitelliste wird mit Parameterdatei emuliert
$ParamStl = "d-stupop"; # d-stlpop, falls LegacyCharset, sonst d-stupop ...
# Keine Direktzugriffe auf die .STL erlaubt (nicht aendern!)
#$DbPfad = ""; # kein STL-Zugriff
# Beschreibung der Kurztitelliste
# Dies funktioniert nicht wirklich, Titel nehmen evtl. das Autorfeld mit!
# sub ParseSTLentry muss dies korrigieren...
@STLStruktur = ('Typ', 'Titel', 'Autor', 'Zeit', 'Signatur', 'Idn');
%STLPositionen = (
# Diesmal keine Anfuehrungszeichen rechts!
# Obacht: 'Titel' speziell, da mit 'Autor' in einem STL-Feld
# Key Start, Laenge
Typ => [1, 1],
Titel => [1, 45], # enthaelt auch Autor
Zeit => [48, 10],
Signatur => [59, 20],
);
# grosse Vorsicht!
# fuer folgende Zeilenarten ist Expansion erlaubt:
%STLexpand = (
'3' => 21, # 'list recnum'
'5' => 13, # list internal
'11' => 21, # 'normal'
'12' => 22, # Verweisungen (gehen ins leere...)
'13' => 21, # Kurztitelzeilen
'21' => 99, # Kurztitelzeilen aus qrix t+ (werden nur gecached)
'22' => 99, # Kurztitelzeilen aus qrix t+ (werden nur gecached)
);
# fuer folgende Zeilenarten ist Angabe der Caption bei der Expansion deaktiviert
%STLsuppresscaption = (
'5' => 1, # reine interne listen
'13' => 1, # Kurztitelzeilensatznummern aus list internal
'99' => 1, # von qrix gelieferte Kurztitelzeilen frueh ausfiltern
);
####################################################### Registersuche #####
our(@AuswRegister, %RegInfo, @Verweisungsformen);
# Folgende Register sollen links angeboten werden (dynamische Version)
@AuswRegister = ('PER', 'TIT', 'ORT', 'SSW', 'SIG');
# Namen der Register fuer die Registerauswahl in den Suchmasken. Diese Texte
# erscheinen in der Pull-Down-Box fuer die Registerauswahl.
# Desweiteren registerspezifische Hilfsseiten und Kurzueberschriften.
# Die Keys sind gleichzeitig symbolische Register fuer Avanti!
# Pro Register enthaelt die Liste 5 Elemente:
# 0. Bookmark in hsintro.htm (genauer $HSUSAGE)
# 1. Name der separaten Hilfedatei ("Hilfe" im Index)
# 2. unbenutzt
# 3. Registerueberschrift (typischerweise laenger als "Scrollbar" von %MaskInfo)
# 4. Beispiele
%RegInfo = (
'#Default#'=> 'PER',
'#Labels#' => ['Bookmark', 'Hilfe', 'Restrok', 'Caption', 'Beispiel'],
PER => ['reg-per', 'per', 1, 'Personen und Körperschaften', 'Lüning, Werner
Südwestfunk <Baden-Baden>'],
KOR => ['reg-kor', 'kor', 1, 'Personen und Körperschaften', 'Lüning, Werner
Südwestfunk <Baden-Baden>'],
TIT => ['reg-tit', 'tit', 1, 'Titel, Stichworte', 'Stiftzahn
drei dunklen Könige'],
STW => ['reg-stw', 'stw', 1, 'Beschreibungen', 'Abdruck
Bestimmungsort'],
SER => ['reg-tit', 'tit', 1, 'Titel, Stichworte', 'Stiftzahn
drei dunklen Könige'],
DAT => ['reg-dat', 'dat', 0, 'zeitl. Datierungen', '1842/03/06'],
ORT => ['reg-ort', 'ort', 0, 'Entstehungsdaten und -orte', '1842/03/06
Güstrow'],
SSW => ['reg-ssw', 'ssw', 0, 'Schlagworte', 'Abschoß'],
SON => ['reg', 'reg', 1, 'Sonderregister', ''],
NLR => ['reg-nlr', 'reg-nlr', 0, 'Nachlassverzeichnis', ''],
INI => ['reg', 'reg', 0, 'Initienregister', ''],
SIG => ['reg-sig', 'sig', 0, 'Signaturen', 'Dit IV
Dit I A 7.1'],
SYS => ['reg-sys', 'sys', 0, 'Systematik', 'Dit IV
Dit I A 7.1'],
);
# Folgende Verweisungsformen sollen im Register erkannt werden
# Spatien davor und dahinter nicht erforderlich
# Reihenfolge wichtig wg. Teilmengenbeziehung!
@Verweisungsformen = ('s.a.->', 'SIEHE AUCH ->', '->->', '->');
####################################################### Suchmaske #####
use vars qw(%MaskenSpecial);
our(%MaskenFelder, @MaskenRegister, @MaskenExtra, @MaskenIndex, $MaskenErstes,
%MaskInfo, @DokTypKeys, %DokTypen);
# Indexsystem fuer Suchmaske
# Definition der Input-Befehle fuer die Suchmaske. Labels bitte nur numerisch
%MaskenFelder = (
'#Labels#'=> ['Vorgabe', 'Extra'],
0 => ['PER', ""],
1 => ['KOR', ""],
2 => ['TIT', ""],
);
# Folgende Register kommen in den Pulldowns der Suchmaske vor
@MaskenRegister = ("", 'PER', 'KOR', 'TIT', 'ORT', 'SIG');
# zusaetzlich angebotene Register in Maskenfeldern mit 'Extra' in %MaskenFelder
@MaskenExtra = ();
%MaskInfo = ( # Bres: Besondere Restriktion beim Browsen via `?`-Knopf
'#Labels#'=> ['Bres', 'Scrollbar', 'STWEnhance'],
"" => ["", ""], # "leer"
PER => ['p', 'Personen'],
KOR => ['k', 'Körperschaften'],
TIT => ["", 'Titel, Stichworte'],
SER => ["", 'Titelanfäge'],
DAT => ["", 'Entstehungszeiten'],
ORT => ["", 'Entstehungsdaten'],
SSW => ["", 'Schlagworte'],
SON => ["", 'Sonderregister'],
NLR => ["", 'Nachlassverzeichnis'],
INI => ["", 'Initien'],
GLO => ["", 'Glossare'],
SIG => ["", 'Signaturen'],
SYS => ["", 'Systematik'],
WRK => ["", 'Lebens- und Wirkungsdaten'],
ALL => ["", "", '&PST &KST OST &NST'],
);
# moegliche Restriktionen
# Angaben analog zu oben
@DokTypKeys = ("", 'b', 'w', 'd');
%DokTypen = (
'#Default#'=> "",
'#Labels#' => ['Erlaeuterung', 'Filter'],
"" => [""],
'p' => ['Personen', 'TYP=p'],
'k' => ['Körperschaften', 'TYP=k'],
'b' => ['Autographen', 'TYP=b'],
'w' => ['Werkmanuskripte', 'TYP=w'],
'l' => ['Lebensdokumente', 'TYP=l'],
'd' => ['Drucke', 'TYP=d'],
'u' => ['Unselbständige', 'TYP=u'],
'n' => ['Werkmanuskripte', 'TYP=n'],
);
%MaskenSpecial = ( # definiert Unterprogramme zur Vorbehandlung
# der suchbegriffe
PER => 'Persify,Trunkify',
KOR => 'Trunkify,AnySTWEnhance',
SIG => 'Trunkify',
TIT => 'Orify',
SSW => 'SWTrunkify',
IDN => 'IDNify',
IDR => 'IDNify,SR',
SYS => 'Sysify',
ALL => 'ANYfy',
);
####################################################### Vollanzeigen #####
# Parameterdateien fuer die Ausgabe
our(@ParamKeys, %Darstellung, @SortKeys, %Sortierung, %ReverseRegister);
#,
# $HasRestr, @RestrKeys, %Restriktionen,
# @BoolKeys, %Suchlogik, @TrunkKeys, %Suchmodus, %Satzarten, %ISprachen
#);
# Allgemeines Schema:
# 'normale' Werte sind von der Form
# Schluessel => [Werteliste]
# Der Spezialschluessel #Labels# gibt Namen fuer die einzelnen Elemente
# der Werteliste, der Schluessel #Default# gibt eine Vorzugsauswahl an.
# Dazu gehoert meist eine weitere Variable, die eine Vorzugsreihenfolge
# angibt, hier ist dies @Paramkeys (beachte die runden Klammern "()"!)
@ParamKeys = ('isbd', 'intern', 'aufgel');
%Darstellung = (
'#Default#'=> 'isbd',
'#Labels#' => ['Erlaeuterung', 'Parameterdatei', 'Codiertabelle'],
isbd => ['Standardanzeige', 'd-2html', 'd-chtml'],
intern => ['HANS-Internformat', 'e-intern', ''],
aufgel => ['expandiertes Format', 'e-extern', ''],
oai_dc => ['DublinCore in OAI', 'e-oai_dc', ''],
json_dc => ['DublinCore als JSON', 'e-jsn_dc', ''],
# alt:
# isbd => ['Standardanzeige', 'd-1html', 'd-html'],
# intern => ['HANS-Internformat', 'e-intern', 'p-hasci'],
# aufgel => ['expandiertes Format', 'e-extern', 'p-hansi'],
);
@SortKeys = qw(ejahrauf ejahrab verfauf verfab titelauf titelab sigauf sigab); # znsort relauf relab
%Sortierung = (
'#Default#'=> 'ejahrauf',
'#Labels#' => ['Erlaeuterung', 'Sortierbefehl'],
ejahrauf => ['nach Erscheinungsjahr (aufsteigend)', 'a 48'],
ejahrab => ['nach Erscheinungsjahr (absteigend)', 'd 48'],
verfauf => ['nach Verfasser (aufsteigend)', 'a 31'],
verfab => ['nach Verfasser (absteigend)', 'd 31'],
titelauf => ['nach Titel (aufsteigend)', 'a 1'],
titelab => ['nach Titel (absteigend)', 'd 1'],
sigauf => ['nach Signatur (aufsteigend)', 'a 59'],
sigab => ['nach Signatur (absteigend)', 'd 59'],
relauf => ['nach Relevanz (aufsteigend)', ""],
relab => ['nach Relevanz (absteigend)', ""],
znosort => ['keine Sortierung', 'a -1'],
);
####################################################### Verweise #####
# Aufloesungen fuer registeruebergreifende Verweise:
use vars qw(%ReverseRegister %AliasRegister @RegAlso $verweisregexp $registerregexp);
%ReverseRegister = (
'1' => 'PER',
'1K ' => 'KOR',
'1P ' => 'PER',
'2' => 'KET',
'3' => 'ORT',
'4' => 'SSW',
'5' => 'SON',
'6' => 'INI',
'8' => 'ENT',
'9' => 'SIG',
':' => 'IDN',
);
# hier werden moeglichst alle in der .hpi definierten Register aufgelistet...
@RegAlso = qw(WRK WIO BIO BER WIZ FTY GES SER EOR SPR JRZ ENT STW E01 E02 E03 E04 NUM OPU IDN IDR);
foreach ( keys %RegInfo, @RegAlso ) {
next unless $_;
next if /^#/;
$ReverseRegister{"$_:"} = $_;
}
###################################### Einlesen externe Konfiguration etc. #####
sub InitHook {
($BaseDb = $Db) =~ s/\d$//; # genutzt zur Bestimmung von ExtConfigFile, kann dort geaendert werden!
if ( $ExtConfig ) {
($ExtConfigFile = "$BaseDb.conf") =~ s/\d+\././ unless defined $ExtConfigFile;
if ( -r "./$ExtConfigFile" ) {
PopDebug->ShowLoad("Including external config file ./$ExtConfigFile\n");
$DbTime = filestat();
unless ( my $return = do "./$ExtConfigFile" ) {
PopDebug->Mess("could not parse $ExtConfigFile: $@") if $@;
PopDebug->Mess("could not 'do' $ExtConfigFile: $!") unless defined $return;
PopDebug->Mess("could not run $ExtConfigFile") unless $return;
}
}
else {
PopDebug->ShowLoad("No external config file ./$ExtConfigFile given\n")};
}
&Defaults();
if ( $SwitchDbSuffix ) {
if ( open (CUR, "<$WRIPATH/current.$SwitchDbSuffix") ) {
$_ = ;
chomp;
$RealDb .= "_x" unless $RealDb =~ /_.$/;
(substr($RealDb, -1), $DbTime) = split(/:/, $_, 3) if $_ =~ /^[ab]:\d+:\d+$/;
close(CUR);
$DbTime = ($DbTime =~ /^\d+$/) ? filestat($DbTime) : "?";
}
else {
PopDebug->Mess("cannot determine RealDb via $WRIPATH/current.$SwitchDbSuffix")};
}
# "Sprach"-spezifika
# spezifische Wendungen, sonst Defaultsprache
my $didl10n;
$didl10n = LoadInterface("de", "./${BaseDb}_%s.l10n");
PopDebug->ShowLoad("l10n-init ".($didl10n ? "[$didl10n fuer de]" : "nicht")." erfolgreich");
# rudimentaere Sprachumschaltung wg. CMS-Einbindung
($Plain = $in{'plain'} || "") unless defined $Plain;
if ( !$Plain ) {
# eingebettete Umgebung aktivieren: xx_lang je vor xx_tpl
$pathpraefix =~ s!(([^;]+)_tpl/)!(-d "${2}_de") ? "${2}_de/;$1" : ((-d "${2}_de") ? "${2}_de/;$1" : $1)!ge;
# Bei Bedarf: BaseDb_lang vor allem anderen
if ( $BaseDb && ($pathpraefix !~ m!${BaseDb}_tpl/!) ) {
if ( -d "./${BaseDb}_de" ) {
substr($pathpraefix, 0, 0) = "${BaseDb}_de/;"};
$pathpraefix .= ";${BaseDb}_tpl/";
};
$Pop = AbsURL($Pop) if $Rebase; # Umgebung hat base-Tag
}
elsif ( $BaseDb && ($pathpraefix !~ m!${BaseDb}_tpl/!) ) {
if ( -d "./${BaseDb}_de" ) {
substr($pathpraefix, 0, 0) = "${BaseDb}_de/;"};
$pathpraefix .= ";${BaseDb}_tpl/";
};
PopDebug->ShowLoad("pathpraefix now: $pathpraefix");
# Verzoegerte Setzungen, da ExtConfig hier hat eingreifen duerfen
$MaxWeightResult = 5 * $MaxAllowResult unless defined $MaxWeightResult;
$MaxWeightOnly ||= "";
# $DbTitle .= ' [mit Diagnostik]' if $Debug;
@MaskenIndex = sort {$a <=> $b} grep !/^#/, keys %MaskenFelder;
$MaskenErstes = $MaskenIndex[0];
@CSSList = sort {$a <=> $b}
map {($CSSURLS{$_} && $CSSURLS{$_}[0]) ? $_ : ()}
grep {!/^#/} keys %CSSURLS;
InitOverride("de") if defined &InitOverride; # last fixes
}
sub LoadInterface {
my($lg, $ifpattern) = @_;
my $if = sprintf($ifpattern, $lg);
unless ( -f "$if" ) {
PopDebug->ShowLoad("Requested external config file $if for '$lg' not found\n");
return undef;
};
our $LangVoid;
PopDebug->ShowLoad("Loading external config file $if for '$lg'\n");
eval { no strict 'vars'; require ("$if"); use strict; } || (PopDebug->Mess("Parse error on loading $if: $@"), return undef);
if ( $LangVoid ) {
PopDebug->ShowLoad("External config file $if for '$lg' deems itself void: $LangVoid\n")};
return $LangVoid ? "" : $lg;
}
###################################### PathInfo auswerten fuer Sub-Server #####
sub DefaultJTHook { # JobTyp setzen (t_xxx evtl. zu strikt bei oai oder SeeAlso/unAPI)
if ( $PathInfo ) {
if ( ($PathInfo =~ /\/[sS]ee[aA]lso\//) && $Features{SeeAlsoServer} ) {
$LegacyCharset = 0; # uses e-u.hpr, always yields UTF-8
return ("seealso", "");
}
elsif ( ($PathInfo =~ /\/oai[_-]?pmh\//) && $Features{OAIRepository} ) {
$LegacyCharset = 0; # uses e-u.hpr, always yields UTF-8
&Populo::OAI::Boot; # enables autoloading of popoai.pm
&OAISetup(@{$Features{OAIRepository}}); # pathpraefix, configfile
&postprocesssettings; # recalculate @pathpraefixe etc.
return ("request", "");
}
};
}
###################################### Nachbehandlung von Ausgaben #####
our ($HTMLEnhance, $AbbrEnhance, $AbbrNoEnhance) = (0, 0, 0); # Werden vom Avanti-Output getoggelt
my @HANSFeatCollect;
my $html_elem_a = 0;
my $html_tag_pending = "";
sub ResultHook {
# Features Scrapen (Mehrere Argumente, PI evtl. auf mehrere Zeilen verteilt)
if ( @HANSFeatCollect ) {
if ( /^\s*$/ ) {}
elsif ( s/^(.*?)\s*\?>// ) {
push(@HANSFeatCollect, split(/\s+/, $1));
substr($_, 0, 0) = &FeatureProc(@HANSFeatCollect);
@HANSFeatCollect = ();
}
elsif ( s/^ - (?=[\w.]+=)// ) {
push(@HANSFeatCollect, $_);
$_ = "";
}
else {
push(@HANSFeatCollect, split(/\s+/, $1));
$_ = "";
}
/^\s*$/ && (undef $_, return);
};
s!\<\?HANSFeat\s+(\w+)\s+(.*?)\s*\?\>!$Features{$1} ? &FeatureProc($1, split(/\s+/, $2)) : ""!ge;
if ( s/\<\?HANSFeat\s+(\w+)\s+(.*?)\s*$// ) {
@HANSFeatCollect = ($1, split(/\s+/, $2));
/^\s*$/ && undef $_;
};
if ( $HTMLEnhance ) {
# replace all :// in text nodes except already within ...
# replace all abbreviations in other text nodes by ABBR elements
if ( /:\/\// || ($AbbrEnhance && /\w\./) ) {
AbbrInit("egal") if $AbbrEnhance & (! $AbbrRE);
my $res = "";
while ( $_ ne "" ) {
if ( $html_tag_pending ) {
if ( s/^(.*?\Q$html_tag_pending\E)// ) {
$res .= $1;
$html_tag_pending = "";
last if $_ eq "";
}
else {
$res .= $_;
last;
}
}
s/^([^<]*)(?=<|$)//;
if ( $html_elem_a ) { # no processing within ...
$res .= $1 if defined $1}
elsif ( defined $1 ) { # (part of) text node
my $text = $1;
$text =~ s!?! $1 !g;
$text =~ s/\b($AbbrRE)\./''.$1.'.<\/abbr>'/geo if $AbbrEnhance && (! $AbbrNoEnhance);
$res .= $text;
};
last if $_ eq "";
if ( s/^(<\/a\s*>)//i ) { # closing
$html_elem_a -- if $html_elem_a;
$res .= $1;
}
elsif ( s/^(<\/[^>]+>)// ) { # closing other
$res .= $1;
}
elsif ( s/^(<\w+\s*)// ) { # start tag any
my $x = $1;
$res .= $x;
$html_tag_pending = ">";
$html_elem_a ++ if $x =~ /^)// ) { # end of tag
$res .= $1; $html_tag_pending = ""; last}
elsif ( s/^(\w+="[^"]*"\s*)// ) {
$res .= $1}
elsif ( s/^(\w+='[^']*'\s*)// ) {
$res .= $1}
elsif ( s/^(\S+\s*)// ) {
$res .= $1}
else {
PopDebug->Mess("HTMLEnhance: Choked on |>$res<|-HERE-|>$_<|");
$res .= $_;
$_ = "";
}
}
}
elsif ( s/(\";
}
elsif ( s/(\";
}
elsif ( s/(\<\?)// ) {
$res .= $1;
$html_tag_pending = "?>";
}
elsif ( s/(\<\!)// ) {
$res .= $1;
$html_tag_pending = ">";
}
else {
s/^(.)// && ($res .= $1)}; # ???
} # while
$_ = $res;
};
# wir sind in der Parameterdatei zu faul ?> auszugeben...
if ( $Features{GNDLink} && /(PND|GKD|SWD)-ID:/ ) { # must be last
s!((PND|GKD|SWD)-ID:(?:\s+|<[^>]+>)+)(\d+-?[0-9xX])\b!$1.&FeatureProc('GNDLink', "$2/$3")!ge;
}
};
sub FeatureProc {
my($fname, @arglist) = @_; # ;-)
my @args = map {$_ ? (htm2iso($_)) : ()} @arglist;
unless ( $Features{$fname} ) {
PopDebug->Interface("Ignoring content for unregistered HANSFeat $fname @args");
return "";
};
no strict 'refs';
PopDebug->Interface("$fname: @args");
return ReParse(&{"proc$fname"}($Features{$fname}, @args));
}
}
sub LinkStable { # fuer interne Verlinkungen: OHNE Tunnel!
return '#e[eb+#' unless defined $_[0];
my ($id, $kind, @extrafields) = @_;
return "" unless $id;
my $script = $Pop;
if ( $kind =~ /\bper/ ) {
$script = $Features{'PermaLink'}->[0] || AbsURL($Pop)}
elsif ( $kind =~ /\b(abs|ext)/ ) {
$script = AbsURL($Pop)}
my $term;
if ( $::USE_Frames && ($kind =~ /\b(per|tun|ext)/) ) {
my $idnpattern = "?t_".($::USE_Frames ? "tunnel=idn&" : "")."idn=%s";
#Populo 1.2x: my $url = sprintf(HtmEsc($idnpattern), urlescape(NormalizeId($id)));
$term = sprintf(HtmEsc($idnpattern), urlescape(NormalizeId($id)));
}
else {
$term = "?t_idn=" . urlescape(NormalizeId($id))};
my @extra;
foreach my $key ( @extrafields ) {
next unless defined $in{$key};
foreach ( split (/\x00/, $in{$key}) ) {
push(@extra, '&'.urlescape($key).'='.urlescape($_)) if length($_)};
};
return join("", $script, $term, @extra);
}
###################################### Vorbehandlung von Suchbegriffen #####
sub Trunkify { # darf veraendern: $register $logik $trunk
# $_ enthaelt Suchbegriff
if ( $Treu ) {
$trunk = "";
return 0;
};
$trunk = '?' unless /\)$/;
return 1;
}
sub noTrunkify { # darf veraendern: $register $logik $trunk
# $_ enthaelt Suchbegriff
return 0 if $Treu;
$trunk = '' unless /\)$/;
return 1;
}
sub IDNify { # darf veraendern: $register $logik $trunk
# $_ enthaelt Suchbegriff
return 0 if $Treu;
s/[=\?]+$//;
$_ .= '=?';
$trunk = '';
$register = "IDN" if $register;
return 1;
}
sub TitAndify { # darf veraendern: $register $logik $trunk
my $escape = /^\"/;
tr/"//d;
if ( $Treu ) {
$trunk = "";
return 0 if $noKlotzSTW;
$_ = "$register \"$_\" OR $register \"$_#\"";
$register = "";
return 0;
}
elsif ( $escape ) { # Worte mit "-Escape immer trunkiert!
tr/?//d; # Trunkierung im inneren verboten
$trunk = '?';
}
else {
&QueryParse(1); # kill stopwords
if ( $noKlotzSTW ) {
s/XxX-Reg-XxX/$register/g}
else {
s/XxX-Reg-XxX "([^"]+\?)"/$register "$1"/g;
s/XxX-Reg-XxX '([^']+\?)'/$register '$1'/g;
s/XxX-Reg-XxX "([^"]+)"/( $register "$1" OR $register "$1\#" )/g;
s/XxX-Reg-XxX '([^']+)'/( $register '$1' OR $register '$1\#' )/g;
};
$register = $trunk = "";
}
return 1;
}
sub AnySTWEnhance {
return 1 unless $register;
my ($auxreg, $suffix) = split(":", GetStrucentry(\%MaskInfo, $register, 'STWEnhance'));
return 1 unless $auxreg;
$suffix = "" unless defined $suffix;
return STWEnhance($auxreg, $suffix);
};
sub STWEnhance {
my ($stwreg, $suffix) = @_;
$stwreg ||= "STW";
$suffix = "?" unless defined $suffix;
my $xsr = "";
($stwreg =~ s/^(&)//) && ($xsr = $1);
my $escape = /^\"/;
tr/"//d;
return 1 if $Treu;
if ( $escape ) { # Worte mit "-Escape immer trunkiert!
tr/?//d; # Trunkierung im inneren verboten
$trunk = '?';
}
else {
my $savq = $_;
s/[, \?\*\$]+$//; # regularize
&QueryParse(1); # kill stopwords
$stwreg = $AliasRegister{$stwreg} if $AliasRegister{$stwreg};
if ( $suffix && $noKlotzSTW ) {
s/XxX-Reg-XxX "([^\"]+)"/($stwreg $xsr"$1$suffix")/g;
}
elsif ( $suffix ) {
s/XxX-Reg-XxX "([^\"]+)"/($stwreg $xsr"$1$suffix")/g;
s/XxX-Reg-XxX '([^\']+)'/($stwreg $xsr'$1$suffix')/g;
}
elsif ( !$noKlotzSTW ) {
s/XxX-Reg-XxX "([^"]+)"/( $stwreg $xsr"$1" OR $stwreg $xsr"$1\#" )/g;
s/XxX-Reg-XxX '([^']+)'/( $stwreg $xsr'$1' OR $stwreg $xsr'$1\#' )/g;
}
else {
s/XxX-Reg-XxX "([^\"]+)"/($stwreg $xsr"$1")/g;
s/XxX-Reg-XxX '([^\']+)'/($stwreg $xsr'$1')/g;
};
$register = $AliasRegister{$register} if $AliasRegister{$register};
if ( !$noKlotzSTW ) {
# das letzte angesprochene Register muss aus hans.h*d*x stammen...
$_ = (($_ =~ /^\s*$/) ? "" : qq! ($_) OR !)
. qq!($register "$savq") OR ($register "$savq [MARK]?")!;
}
else {
# das letzte angesprochene Register muss aus hans.h*d*x stammen...
$_ = (($_ =~ /^\s*$/) ? "" : qq! ($_) OR !) . qq!($register "$savq")!;
};
$register = $trunk = "";
}
return 1;
}
sub ANYfy { # Stichworte auf viele Register verteilen
$trunk = "";
&QueryParse(0); # don't kill stopwords
my @rawlist = split(/\s+/, GetStrucentry(\%MaskInfo, $register, 'STWEnhance'));
my (@reglist, @srlist);
foreach ( @rawlist ) {
s/&(?:amp;)?// ? push(@srlist, $AliasRegister{$_} || $_) : push(@reglist, $AliasRegister{$_} || $_) };
s/XxX-Reg-XxX \"([^"]+)\"/" ( ".join(" or ", (map{qq!$_ "$1"!} @reglist), (map{qq!$_ &"$1"!} @srlist))." ) "/ge;
$register = "";
return 1;
}
######################################################################
# Vorgaben fuer Werte, damit anfangs nicht alles in die URL muss...
%Defaults = (
'JobTyp' => undef, # spaeter anhand Use_Frames bestimmt, falls in .conf-Datei nicht explizit belegt
'index' => 'PER',
zeilen => 10,
modus => "", # don't touch this (interferes with "treu")
logik => 'AND',
treu => "",
plain => "", # generisches Layout (etwa fuer "printer friendly")
autopresent => "reg", # Registerausschnitt bei show von Normdaten
);
######################################################################
# Datenbankspezifische Unterroutinen
# zu einem Record wird die Kurztitelzeile geholt und aufbereitet
#
# Uebergeben wird
# localtyp: LineTyp der Zeile
# $line: STL-Eintrag, bereits auf $Stl Zeichen mit Leerzeichen aufgefuellt
# $recno: zugehoerige Satznummer
#
# Return mit
# Skalar: (neuer) LineTyp
# Hash: leer
# Array: Komponenten der Kurztitelliste
# Im Array bleiben fuehrende und folgende Spatien erhalten!
sub ParseSTLentry {
my ($localtyp, $line, $recno) = @_;
my ($key, @returnarray, %returnhash);
if ( $ParamStl ) {
my (@components) = split(/\x09/, $line);
foreach $key ( @STLStruktur ) {
my $value = shift(@components);
$value = "" unless defined $value;
push(@returnarray, $value);
$returnhash{$key} = $value;
}
}
else {
foreach $key ( @STLStruktur ) {
next if $key eq "Autor";
my $value = "";
if ( $STLPositionen{$key} ) {
my ($start, $len) = @{$STLPositionen{$key}};
$value = substr ($line, $start, $len);
};
$returnhash{$key} = $value;
push (@returnarray, $value);
};
if ( $returnhash{'Titel'} =~ m!^(.{30}) /(.*)$! ) {
($returnhash{'Titel'}, $returnhash{'Autor'}) = ($1, $2)}
else {
$returnhash{'Autor'} = ""};
# split (/ \/ /, $returnhash{'TitelAut'}); bei freierer Form
}
$returnhash{'StammSatz'} = ($returnhash{'Typ'} eq " ");
foreach $key ( @STLStruktur ) {
$returnhash{$key} =~ s/^\s+//;
$returnhash{$key} =~ s/\s+$//;
}
return ($localtyp, {%returnhash}, [@returnarray]);
}
sub STLmap {
my $ref = ($_[0])->[2]; # $_[0] ist Referenz auf Array...
# sortiere nach Verfasser / Jahr / Titel
# (my $year = $$ref[3]) =~ s/(\d{2})\/(\d{2})\/(\d{4})/$3-$2-$1/;
my $year = $$ref[3]; # dumm: AddSTL plaettet Sortierform
($year =~ /(\d{4})/) && ($year = $1);
# Populo 1.16: ansi2sort, abgeloest durch win2sor
# Populo 1.2x: Werte hier sind utf-8, win2sor wird unten auf iso2sor gealiast
return join("\x01", win2sor($$ref[2]), $year, win2sor($$ref[1]));
}
######################################################################
our($Register, $FirstVal, $NextVal);
# gelesene Indexzeile wird auf Verweise untersucht und aufgespalten:
# NextVal wird gesetzt fuer Zugriff
# Registerpraefix wird abgeschnitten (for convenience)
# Typ 1 und 2: LineTyp: Typ
# C_Recno: Satznummern
# C_Count: Zaehlung,
# C_Toobig: Zaehlung zu gross
# Typ 0: C_Val[0]: Registerzeile
# Typ 1: C_Val[0]: Verweisquelle
# C_Val[1]: Verweisung
# C_Val[2]: Verweisziel
sub ParseRegisterline {
my ($count, $c0, $recs) = @_;
my ($c1, $c2, $typ, $toobig, $targetreg);
my $bold = 0;
# ($c0, $c1) = split(/\s*\xc1/, $c0); # (OSTWEST-hat nix)
($c0, $c1) = split(/\s*_[a-z0-9+]+_?/, $c0); # Uebernahmeschluessel killen
if ( $Register eq 'TIT' ) {
if ( $c0 =~ s/\x23$// ) { } # Reg.2-Kloetzchen (# = OSTWEST-35)
elsif ( $c0 =~ s/[ "]+$// ) {
# substr ($c0, 0, 0) = '"';
$bold = 1;
}
}
elsif ( $Register eq 'ORT' ) {
$c0 =~ s/\x23$//; # Reg.3-Kloetzchen (# = OSTWEST-35)
};
($NextVal = $c0) =~ s/[\"\?]//g;
($NextVal, $c1) = split(/\s+\.\.\.\s+/, $NextVal) if $Register =~ /^(SIG|SYS)$/;
# $NextVal = escape($NextVal);
$FirstVal = $NextVal unless defined $FirstVal;
$c1 = $c2 = $targetreg = $toobig = "";
if( $count =~ /\>(.*)/) {
$count = $1;
$toobig = "\>";
};
# $count = sprintf("%5d", $count); # wird rechtsbuendig aufgefuellt...
# $verweisregexp korrespondiert zu Verweisungsformen weiter oben!
if ( /($verweisregexp)/ ) {
$typ = 1;
($c0, $c1, $c2) = split (/\s*($verweisregexp)\s*/, $c0, 2);
$c1 =~ s/\s+$//;
$c1 =~ s/^\s+//;
$c2 =~ s/\xb7$//; # Mittiger Punkt (Ostwest-250 = DOS-250)
if ( $c2 =~ s/^\|($registerregexp)\s*// ) {
$targetreg = $ReverseRegister{$1}};
if ( $c1 =~ /^s\.a\./ ) {
$c1 =~ s/\s+//g; # garkeine Blanks
$typ = 8; # 1. Haelfte nicht als Link...
};
if ( $Register eq 'TIT' ) {
$c0 =~ s/^\"//};
}
elsif ( $Register =~ /^(SIG|SYS)$/ ) {
($c1, $c0) = split(/\s+\.\.\.\s+/, $c0);
$c0 = $c1 unless defined $c0;
$typ = 0;
}
else {
$typ = 0};
return ($typ, {Main=>$bold, Count=>$count, Toobig=>$toobig, TargetReg=>$targetreg}, [$c0, $c1, $c2]);
}
######################################################################
# Einkapseln von Datenbankreferenzen
# Form war !LI:[?]:[]!!
# Der optionale ist dabei mit y0 formatiert,
# d.h. noch ASCII (Ostwest)
# Der anzuzeigende Begriff ist aber ANSI bzw. HTML gewesen...
# wir bekommen jedenfalls bereits vier Uebergabeparameter
sub LinkEscape { # !LI:!!
my ($qualify, $register, $suchbegriff, $anzeige) = @_;
my ($modus) = "";
local ($_);
my $rawbegriff;
unless ( $LegacyCharset ) { # Kompatibilitaet populo <1.20
$rawbegriff = $suchbegriff;
$suchbegriff = urlescape($suchbegriff);
}
unless ( $register ) { # REL-... Konstruktionen von Protokoll-Version 2
if ( $suchbegriff =~ s/^REL-(\w+)(:|%3A)// ) {
my $rel = $1;
my $id = urlescape(NormalizeId($rawbegriff || urlunescape($suchbegriff)));
return qq($anzeige);
}
elsif ( $Debug ) { # oder Unbekannte Register...
PopDebug->Mess("unrecognized query '$suchbegriff' for '$anzeige'");
return "[$anzeige]";
}
else { # oder Unbekannte Register...
return "[$anzeige]"}
}
# Typ 'acindex' fuer ?-Begriffe, 'allegro' sonst
my ( $ty ) = $qualify ? 'acindex' : 'allegro';
if ( $ty ne 'acindex' ) { # registerspezifische Sonderbehandlung
if ( $register eq 'TIT' ) {
substr ($suchbegriff, 0, 0) = urlescape('"');
$modus = '&modus=';
}
# Sonderbehandlung fuer Hans'97b, unbedingt deaktivieren fuer H2k
};
if ( $ty eq 'acindex' ) { # JobTyp 'acindex' mit Parametern index u. s1
if ( ($register eq "SYS") && ($suchbegriff =~ s/^N\.//)) {
$suchbegriff =~ s/(%20)+%23$//;
return qq($anzeige);
}
$_ = "&index=$register&s1=$suchbegriff";
}
elsif ( $register eq 'IDN' ) { # JobTyp 'idn'
my $id = urlescape(NormalizeId($rawbegriff || urlunescape($suchbegriff)));
return qq($anzeige);
}
else { # JobTyp 'allegro' mit Parameter q_0, v_0
$_ = "$modus&v_$MaskenErstes=$register&q_$MaskenErstes=$suchbegriff";
};
return qq($anzeige);
}
# Vorwaertskompatibilitaet populo 1.20
sub TplHook {
s/\$\{([A-Z]\w*)\}/PO!$1!/g; # wg. TextOrFile: ${Variable} -> PO!Variable!
}
$USE_Cookies = 0; # Einstellungen ueber Cookies nicht erlaubt
################# THESE FUNCTIONS ARE AUTOLOADED ON DEMAND ####################
BEGIN {
%MYSUBS = (
####
## Auxiliary Subroutines
####
'Persify' => <<'END_OF_FUNC',
sub Persify { # Person etwa als VN NN eingegeben?
return 0 if $Treu;
return 1 unless /\s/;
return 1 if /[\<\[]/;
my $savq = $_;
my $savreg = $register;
if ( /\,/ ) {
s/^d'//;
s/\s(de|du|of|van|van der|von|von der|von und zu)$//i;
}
else {
my @parts = split(/\s/, $_);
my $bla = pop(@parts) . ", " . join(" ", @parts);
$bla =~ s/^d'//;
$bla =~ s/\s(de|du|of|van|van der|von der|von und zu)$//i;
$register = $AliasRegister{$register} if $AliasRegister{$register};
$_ = "( $register \"$_\?\" ) OR ( $register \"$bla\?\" )";
$register = $trunk = "";
s/\svan$//;
}
my $addon = "";
my ($auxreg, $suffix) = split(":", GetStrucentry(\%::MaskInfo, $savreg, 'STWEnhance'));
my $xsr = "";
($auxreg =~ s/^(&)//) && ($xsr = $1);
if ( $auxreg ) {
local($_) = $savq;
&QueryParse(1); # kill stopwords
my $stwreg = $AliasRegister{$auxreg} || $auxreg;
if ( $suffix eq "?" ) {
s/XxX-Reg-XxX "([^\"]+)"/(($stwreg $xsr"$1") OR ($stwreg $xsr"$1$suffix"))/g}
elsif ( $suffix ) {
s/XxX-Reg-XxX "([^\"]+)"/($stwreg $xsr"$1$suffix")/g}
else {
s/XxX-Reg-XxX "([^\"]+)"/($stwreg $xsr"$1")/g}
$addon = $_;
};
# das letzte angesprochene Register muss aus cat.adx stammen...
$_ = qq!$register "$_?"! if $register;
if ( $addon ) {
$_ = qq!( $addon ) or $_!;
$register = $trunk = "";
}
return 1;
}
END_OF_FUNC
'SWTrunkify' => <<'END_OF_FUNC',
sub SWTrunkify {
if ( $Treu ) {
s/\?$/*/;
return 0;
};
s/\s+$//;
$_ = "( $register \"$_\" ) OR ( $register \"$_ /\?\" ) OR ( $register \"$_ / SW\" )";
# Letzte Form benoetigt bei "LastResortSW"
$register = $trunk = "";
return 1;
}
END_OF_FUNC
'Orify' => <<'END_OF_FUNC',
sub Orify {
if ( $Treu ) {
$_ = "$register \"$_\" OR $register \"$_#\"";
$register = $trunk = "";
return 0;
}
my $escape = /^\"/;
tr/"//d; # Trunkierung im inneren verboten
if ( /\s/ && (! $escape) ) { # mehrere Worte ohne "-Escape
s/\s+/xXx\" OR $register \"/g;
substr($_, 0, 0) = "$register \"";
$_ .= "xXx\"";
s/\?xXx/\?/g;
if ( $noKlotzSTW ) {
s/xXx/$trunk/g}
elsif ( $trunk ) {
s/xXx/$trunk/g}
else {
s/$register "(\S)xXx"/$register "$1" OR $register "$1\#"/g};
$register = $trunk = "";
}
elsif (/\s/) { # mehrere Worte mit "-Escape immer trunkiert!
tr/?//d; # Trunkierung im inneren verboten
$trunk = '?';
$_ = "\"$_\"";
}
elsif ( $trunk or /\?$/ ) { # as is
}
else { # Ein Wort stets wie ohne "-Escape
tr/?//d; # Trunkierung im inneren verboten
$_ = "\"$_\" or $register \"$_#\"" unless $noKlotzSTW;
}
return 1;
}
END_OF_FUNC
'SR' => <<'END_OF_FUNC',
sub SR { # darf veraendern: $register $logik $trunk
# $_ enthaelt Suchbegriff
if ( $Treu ) {
$sr = "";
return 0;
};
if ( $register ) {
$_ = " $register \"$_$trunk\" ";
$register = $trunk = "";
};
if ( s/\&?"\&?([^"]+)"/\&"$1"/g ) { # action in pattern
}
else {
s/^\s*(.+)\s*$/&"$1"/};
return 1;
}
END_OF_FUNC
'Sysify' => <<'END_OF_FUNC',
sub Sysify { # Nur Platzhalter, damit .conf-Datei ggfls. eigenes bereitstellen kann
return 1;
}
END_OF_FUNC
'WeightQuery' => <<'END_OF_FUNC',
sub WeightQuery {
return '#bvv[ve#' unless defined $_[0];
my ($strucref, $labeltreffer, $labelrecnums, $labelinitweight, $limit) = @_;
$labelinitweight ||= "InitWeight";
$limit ||= 0;
my $i = &searchlabel( $strucref, $labeltreffer );
my $j = &searchlabel( $strucref, $labelrecnums );
my $w = &searchlabel( $strucref, $labelinitweight );
my %weightrecs = ();
my ($k, $weight);
$RecnumsMaxweight = 0;
foreach $k ( keys %$strucref ) {
next if $k =~ /^#/; # Ueberschriften etc.
next unless $$strucref{$k}[$i];
PopDebug->Query("WeightQuery $k -- @{$strucref->{$k}}");
$weight = ($$strucref{$k}[$w] || 1) / $$strucref{$k}[$i];
PopDebug->Query("Weight for term $k calculated to $weight");
$RecnumsMaxweight += $weight unless $weight < 0;
foreach ( split(/,/, $$strucref{$k}[$j]) ) {
next unless $_;
# $weightrecs{$_} = 0 unless exists $weightrecs{$_};
$weightrecs{$_} += $weight;
};
};
# $Recnumsnum = scalar keys %weightrecs;
# $Recnums = join(",", map { $_->[1] }
# sort { $b->[0] <=> $a->[0] }
# map { [$weightrecs{$_}, $_] if ($weightrecs{$_} > $minweight }
# keys %weightrecs);
my %byweight = ();
$RecnumsMax = 0;
while ( ($_, $weight) = each %weightrecs ) {
push(@{$byweight{$weight}}, $_);
$RecnumsMax ++;
};
$Recnumsnum = 0;
$Recnums = "";
foreach $weight ( sort {$b <=> $a} keys %byweight ) {
my $cut = "";
my $delta = @{$byweight{$weight}};
if ( $Recnums ) {
if ( $weight < 0 ) {
$cut = "negative weight"}
elsif ( $limit && ($Recnumsnum > $limit) ) {
$cut = "limit $limit exceeded"}
elsif ( $limit && ($Recnumsnum + $delta > $limit) ) {
$cut = "limit $limit would be exceeded"}
elsif ( $::MaxWeightOnly ) {
$cut = "only maximal weight shall be regarded"};
}
unless ( $cut ) {
$Recnumsnum += $delta;
$Recnums .= ($Recnums ? "," : "") . join (',', @{$byweight{$weight}});
};
PopDebug->Query("Weight $weight: ", scalar (@{$byweight{$weight}}),
" records [", ($cut ? "SKIPPED: $cut]" : "SIGMA: $Recnumsnum"), "]");
};
return "";
}
END_OF_FUNC
'SplitQuery' => <<'END_OF_FUNC',
sub SplitQuery {
return '#bee#' unless defined $_[0];
my($indexref, $reg);
my ($indexref, $reg, $val) = @_;
local $_ = $val;
&BasicTrimify;
%::Query = () unless %::Query;
@::QueryNummern = () unless @::QueryNummern;
$::QueryNum = scalar @::QueryNummern;
# 0 1 2 3 4 5
$::Query{'#Labels#'} ||= ['OrigKey', 'Register', 'Begriff', 'InitWeight', 'Treffer', 'Query'];
my ($andlist, $orlist, $notlist) = ([], [], []);
my @terms = split (/\s+/, $_);
my $collecting = "";
my $collect;
my $baselist = $orlist;
my $whatlist = $baselist;
my $boost = 0;
while ( @terms ) { # naechster Durchlauf regulaer: $whatlist wird $andlist
# also mit next erzwingen, falls $whatlist gesetzt wird
$_ = shift @terms;
next unless defined $_;
$boost = 1 unless $boost;
# aktueller Term zu ergaenzen?
if ( $collecting ne "" ) {
if ( s/($collecting)$// ) {
$collect .= " $_";
}
else {
$collect .= " $_";
next if @terms;
}
$collect =~ tr/"//d;
push (@$whatlist, ['"'.$collect.'"', $boost]);
$collecting = "";
$boost = 0;
next;
};
if ( s/^\+// ) {
$whatlist = $andlist}
elsif ( s/^\-// ) {
$whatlist = $notlist}
elsif ( s/^(\!+)// ) {
$boost = 10 ** length($1);
$whatlist = $orlist;
}
elsif ( s/^(\#+)// ) {
$boost = -10 ** (length($1) -1);
$whatlist = $orlist;
}
elsif ( /^AND$/ ) {
$baselist = $andlist;
if ( @terms && ($terms[0] =~ /^NOT$/) ) {
$baselist = $notlist;
shift @terms;
}
next;
}
elsif ( /^UND$/ ) {
$baselist = $andlist;
if ( @terms && ($terms[0] =~ /^NICHT$/) ) {
$baselist = $notlist;
shift @terms;
}
next;
}
elsif ( /^OR$/ ) {
$baselist = $orlist;
if ( @terms && ($terms[0] =~ /^NOT$/) ) {
shift @terms;
push (@$baselist, ["!ILLEGAL!", 0]);
}
next;
}
elsif ( /^ODER$/ ) {
$baselist = $orlist;
if ( @terms && ($terms[0] =~ /^NICHT$/) ) {
shift @terms;
push (@$baselist, ["!ILLEGAL!", 0]);
}
next;
}
elsif ( /^(NOT|NICHT)$/ ) {
$baselist = $notlist;
next;
}
else {
$whatlist = $baselist};
next if $_ eq "";
if ( /^([\'\"])(.+)?\1$/ ) {
push (@$whatlist, [$2, $boost]) if defined $2}
elsif ( s/^([\'\"])// ) {
$collecting = quotemeta($1);
$collect = $_;
next;
}
elsif ( s/^\w'//i ) {
push (@$whatlist, [$_, $boost]) if $_ ne ""}
elsif ( /^.$/io ) { # Einzelzeichen
}
else {
s/[.,:!'"]+$//; s/^[.,:!]+//; # staerker normieren
push (@$whatlist, [$_, $boost]);
};
$baselist = $orlist;
$boost = 1;
};
if ( $collecting ne "" ) { # schliessendes " hat also immer noch gefehlt...
PopDebug->Query("still collecting: $collect");
push (@$whatlist, ['"'.$collect.'"', $boost]);
};
my (@reglist, @srlist);
if ( my $list = GetStrucentry(\%::MaskInfo, $reg, 'STWEnhance') ) {
foreach ( split(/\s+/, $list) ) {
s/&(?:amp;)?// ? push(@srlist, $AliasRegister{$_} || $_) : push(@reglist, $AliasRegister{$_} || $_) };
}
else {
@reglist = ($reg)};
my $fix = "";
my $termpattern = "( ".join(" or ", (map{qq!($_ "YyY-Trm-YyY")!} @reglist), (map{qq!($_ &"YyY-Trm-YyY")!} @srlist))." ) ";
PopDebug->Query("\ttermpattern: $termpattern");
if ( @$andlist ) {
PopDebug->Query("\tandlist: ".join(" / ", map{$_->[0]} @$andlist));
$fix .= " AND ".join(" AND ", map{ expandoneterm($termpattern, $_->[0]) } @$andlist);
};
if ( @$notlist ) {
PopDebug->Query("\tnotlist: ".join(" / ", map{$_->[0]} @$notlist));
$fix .= " NOT ".join(" NOT ", map { expandoneterm($termpattern, $_->[0]) } @$notlist);
};
PopDebug->Query("\tfix: $fix");
if ( @$orlist ) {
PopDebug->Query("\torlist: ".join(" / ", map{"$_->[0] ($_->[1])"} @$orlist));
foreach my $q ( @$orlist ) {
my $qt = expandoneterm($termpattern, $q->[0]);
my $qw = $q->[1];
$::Query{$::Querynum} = [$reg, "", ($fix ? "($qt$fix)" : $qt), $qw, 0];
PopDebug->Query("\texpanded orlist term: $qt with weight $qw");
push(@::QueryNummern, $::Querynum++);
}
}
elsif ( $fix =~ s/^\s+AND\s+// ) {
$::Query{$::Querynum} = [$reg, "", $fix, 1, 0];
push(@::QueryNummern, $::Querynum++);
}
else {
PopDebug->Mess("Cannot parse query >$val<")}
return "";
}
sub expandoneterm {
local $_ = shift; # template
my $term = shift;
unless ( $term =~ /^"/ ) {
s/YyY-Trm-YyY/$term/g;
return $_;
};
$term =~ tr/"//d;
my @wordlist = split(/[,]* /, $term);
$term =~ tr/?*$//;
s/([A-Z]+ .?)\"YyY-Trm-YyY\"/qq!($1"$term?") OR (!
.join(" AND ", map {qq!($1"$_")!} @wordlist)
.qq!)!/ge;
return $_;
}
END_OF_FUNC
'PrepDownload' => <<'END_OF_FUNC',
sub PrepDownload {
return '#b#' unless defined $_[0];
my $vacc = "#uSV $::ProtVer\n";
$vacc .= "#uDB x\n" if $Debug;
$vacc .= "#uCS x\n" unless $LegacyCharset;
if ( %::Features ) {
my @featlist = sort grep !/(^#|:)/, keys %::Features;
$vacc .= "#uFT ! @featlist !\n" if @featlist;
}
return $vacc;
}
END_OF_FUNC
#### fuer SeeAlso-Server ###
'NormalizeId' => <<'END_OF_FUNC',
sub NormalizeId { # interne Identnummer -> Global
return "#e[e#" unless defined $_[0];
local($_) = @_;
my $canonical = $_[1] || "";
return "" unless $_;
my $gid = $canonical ? "" : $::DbIdPfx;
if ( m~://~ ) { $gid .= $_ }
elsif ( s~^GND[:/]?~~i ) { tr/x/X/; $gid .= "http://d-nb.info/gnd/$_"; }
elsif ( s~^PND[:/]?~~i ) { tr/x/X/; $gid .= "http://d-nb.info/gnd/$_"; }
elsif ( s~^GKD[:/]?~~i ) { tr/x/X/; s/(.)$/-$1/; $gid .= "http://d-nb.info/gnd/$_"; }
elsif ( s~^SWD[:/]?~~i ) { s/(.)$/-$1/; $gid .= "http://d-nb.info/gnd/$_"; }
elsif ( s~^ZKA[:/]?~~i ) { $gid .= "zka:$_"; }
elsif ( /^[a-z]+:/ ) { $gid .= $_ }
elsif ( $::DbIdPfx ) { tr/+/_/; $gid .= $_ }
else { $gid .= $_ };
return $::DbIdNSId ? "info:ofi/nam:info:oai:${main::DbIdNSId}:".&::urlescape($gid, q) : $gid;
}
END_OF_FUNC
'DeNormalizeId' => <<'END_OF_FUNC',
sub DeNormalizeId { # Vorbehandlung geprefixte-IDs
return "#e#" unless defined $_[0];
local($_) = @_;
return "" unless $_;
if ( m~(?:http://)?d-nb.info[/:]gnd[/:](\d+\-?[\dxX])$~ ) {
$_ = $1;
my $typ = anagnd($_);
substr($_, 0, 0) = "$typ:";
tr/X-/x/d;
return $_;
};
if ( my $stripre = join("|", map {quotemeta($_)} reverse sort @::IdPrefixStrip) ) {
PopDebug->Query("want to strip /^$stripre/ from $_");
s/^$stripre//o;
};
if ( /^oai:/ ) { # Default-OAI-Praefix vorsichtshalber entfernen
my $nsre = join("|",
map { m!^(.*://)?([^/]+)! ? quotemeta($2) : ()}
reverse sort ($::Features{'Permalink'}->[0] || &::AbsURL("/"), @IdPrefixStrip)
);
if ( $nsre ) {
my $nsid = $::DbIdPfx || $::Db.":";
PopDebug->Query("want to strip /^oai:($nsre):$nsid/ from $_");
s/^oai:($nsre):$nsid//;
};
};
return "" unless $_;
if ( /^info/ && $::DbIdNSId ) {
PopDebug->Query("want to strip /^info:ofi/nam:info:oai:${main::DbIdNSId}:/ from $_");
s~^\Qinfo:ofi/nam:info:oai:${main::DbIdNSId}:\E~~;
$_ = urlunescape($_);
};
if ( $::DbIdPfx ) {
PopDebug->Query("want to strip /^$::DbIdPfx/ from $_");
s~^\Q$::DbIdPfx\E~~;
tr/_/+/;
};
if ( /^[a-z]+:/ ) { return $_ }
elsif ( s~^GND[/:]?~~i ) { tr/X/x/; return "gnd$_" }
elsif ( s~^PND[/:]?~~i ) { tr/X/x/; return "pnd$_" }
elsif ( s~^GKD[/:]?~~i ) { tr/X-/x/d; return "gkd$_" }
elsif ( s~^SWD[/:]?~~i ) { tr/-//d; return "swd$_" }
elsif ( s~^ZKA[/:]?~~i ) { return "zka$_" }
if ( $DbIdPfx && m~\Q$::DbIdPfx\E([:\w+]+)$~ ) {
($_=$1) =~ tr/:-//d}; # Zunehmende Verzweiflung
return $_;
}
sub anagnd {
local($_) = @_;
return "" unless $_;
# GND ab 4/2012: Fest 9 Stellen, Pruefziffer 0-9,X
# PND ab 4/2011: Fest 9 Stellen, Pruefziffer 0-9,X
if ( /^(10\d{7})([0-9Xx])$/ ) { return "PND" }
# PND: Fest 8 Stellen, Pruefziffer 0-9,X
elsif ( /^(1[0-6]\d{6})([0-9Xx])$/ ) {
# Knifflig: 9stellig ohne "-": Pruefziffernalgorithmus anwenden fuer test auf PND/GKD
my ($i, $p) = ($1, $2);
if ( prfz($i, $p, -9) ) { return "PND" }
elsif ( prfz($i, $p, 9) ) { return "GKD" }
}
# SWD: fest 7 Stellen, -, Pruefziffer 0-9
elsif ( /^(4[0-9]|7[5-9])\d{5}-?[0-9]$/ ) { return "SWD" }
# GKD: variabel 1-8 Stellen, -, Pruefziffer 0-9,X
elsif ( /^[1-9]\d{0,7}-?[0-9xX]$/ ) { return "GKD" };
return "unknown.gnd";
}
sub prfz {
my ($id, $pr, $al) = @_;
return undef unless defined $pr;
$pr =~ s/^-?([\dxX])$/$1/ or return 0;
($pr =~ /^[xX]$/) && ($pr = 10);
my @p;
if ( $al > 0 ) {
@p = (2 .. $al)}
else {
@p = reverse (1 .. -$al)};
return 0 if length($id) > scalar @p;
my $z = 0;
foreach ( reverse split(//, $id) ) {
$z += ($_ * shift @p)}; # % 11 ...;
$z %= 11;
return $z == $pr;
}
END_OF_FUNC
#### Feature Processing ###
'procGNDLink' => <<'END_OF_FUNC',
sub procGNDLink {
return '#ee[e#' unless defined $_[0];
my ($featref, $id, $wantbutton) = @_;
my $urlpattern = $featref->[0] or return "";
my $typ = "GND";
($id =~ s!^(gkd|pnd|swd|zdb|dnb)[/:]!!i) && ($typ = $1);
$typ =~ tr[a-z][A-Z];
#Populo 1.2x: my $url = sprintf(HtmEsc($urlpattern), urlescape($id));
my $url = sprintf(HtmEsc($urlpattern), urlescape($id));
if ( $wantbutton ) {
return qq($typ Info)}
else {
return qq($id)};
}
END_OF_FUNC
'procStupidGNDLinks' => <<'END_OF_FUNC',
sub procStupidGNDLinks {
return '#ee[e#' unless defined $_[0];
my ($featref, $id, $pattern) = @_;
$id =~ tr[x][X]d;
(my $svcid = $id) =~ s~^(gkd|pnd|swd)[/]?~~i;
my @result;
foreach my $service ( grep /^\Q$pattern\E/, @::StupidGNDLinksUsed ) {
$svcid ||= urlescape($id);
#Populo 1.2x: my $label = GetStrucentry("StupidGNDLinks", $service, 'Prefix');
next unless my $svcurl = $::StupidGNDLinks{$service}[0];
unless ( @result ) {
my $intro = $featref->[0];
$intro = "" if $intro =~ /^.$/; # Einzelzeichen: Kein Text
($intro .= ": ") =~ s/\s*(:\s*)+/: / if $intro;
push(@result, ''.Htm($intro).'
') if $intro;
};
my $url = sprintf(Htm($svcurl), urlescape($id));
my $label = Htm($::StupidGNDLinks{$service}[1] || "");
my $tooltip = Htm($::StupidGNDLinks{$service}[2] || "");
my $format = $::StupidGNDLinks{$service}[3] || "populo_linkbutton";
push(@result, qq($label
));
};
push (@result, '') if @result;
return join("\n", @result);
}
END_OF_FUNC
'procSeeAlsoClient' => <<'END_OF_FUNC',
sub procSeeAlsoClient {
return '#ee[e#' unless defined $_[0];
my ($featref, $id, $pattern) = @_;
$id =~ s/x$/X/;
my @result;
foreach my $service ( grep /^\Q$pattern\E/, @::SeeAlsoServicesUsed ) {
my $svcid;
if ( $id =~ /:/ ) { # qualifiziert...
$svcid = urlescape($id)}
elsif ( $service =~ /^(pnd|swd|gkd)/ ) { # ID fuer GBV-Dienste normieren
($svcid = $id) =~ s~^(gkd|pnd|swd)[/]?~~i;
$svcid = urlescape(sprintf(($service =~ /viaf/) ? "%s" : "http://d-nb.info/gnd/%s", $svcid)); # pnd2viaf nur nackte Nummer...
};
$svcid ||= urlescape($id);
#Populo 1.2x: my $label = GetStrucentry("SeeAlsoServices", $service, 'Prefix');
# my $svcurl = $::SeeAlsoServices{$service}[0] || "";
my $label = $::SeeAlsoServices{$service}[1] || "";
my $tooltip = $::SeeAlsoServices{$service}[2] || "";
my $format = $::SeeAlsoServices{$service}[3] || "";
# my $filter = $::SeeAlsoServices{$service}[4] || "";
($label .= ": ") =~ s/\s*(:\s*)+$/: /g if $label;
($label =~ /[^\x00-\x7f]/) && ($label = Htm($label));
my $container_el;
if ( $format =~ /(UL|OL)/ ) {
$container_el = 'div';
$label = qq!$label
! if $label;
}
else {
$container_el = 'span';
$label = qq!$label! if $label;
};
my $inner = $format ? qq!<$container_el title="$svcid" class="hans_seealso-inner $service seealso-$service">!
: qq!<$container_el title="$svcid" class="hans_seealso-inner $service seealso-csv">!;
push(@result, qq(<$container_el class="hans_featseealso-$service seealso-container" style="display: none;">$label$inner));
};
return join("\n", @result);
}
END_OF_FUNC
'procSeeAlsoServer' => <<'END_OF_FUNC',
sub procSeeAlsoServer {
return '#e#' unless defined $_[0];
my ($featref, $id) = @_;
return "" unless $id;
my $wid = urlescape(NormalizeId($id));
return qq();
}
END_OF_FUNC
'procBestForm' => <<'END_OF_FUNC',
# Die folgende Routine regelt das Einfangen von
# in der Ausgabe
# In der Parameterdatei dann an geeigneter Stelle:
#uFt +#00a0 c" BestForm " Z
#nr +#00a1 Z
#uJD p{C ''}
#00a1
# (Beispiel mit Layout in d-lokal)
# Kopie der folgenden Routine in der eigenen hans.conf ist staerker also folgende:
sub procBestForm {
return '#ee#' unless defined $_[0];
my ($featref, $id) = @_;
return "" unless $id;
my ($urlpattern, $label, $tooltip) = @$featref;
return "" unless $urlpattern;
$label ||= "Bestellen";
$tooltip ||= "";
#Populo 1.2x: my $url = sprintf(HtmEsc($urlpattern), urlescape(NormalizeId($id)));
my $url = sprintf(HtmEsc($urlpattern), urlescape(NormalizeId($id)));
return "" unless $url;
# Es folgt das HTML-Fragment
return qq($label);
}
END_OF_FUNC
'procPermaLink' => <<'END_OF_FUNC',
sub procPermaLink {
return '#ee[e#' unless defined $_[0];
my ($featref, $id, $reclabel) = @_;
return "" unless $id;
$reclabel ||= "diesen Datensatz";
my ($urlprefix, $label, $tooltip, $icon) = @$featref;
return unless $urlprefix;
$urlprefix .= "?t_".($::USE_Frames ? "tunnel=idn&" : "")."idn=%s";
$id = NormalizeId($id);
##Populo 1.2x: my $url = sprintf(HtmEsc($urlpattern), urlescape($id));
my $url = HtmEsc(sprintf($urlprefix, urlescape($id)));
$label = Htm(sprintf($label || "Permalink", $reclabel));
my $visible = $icon ? qq!
! : qq!$label!;
$tooltip = Htm(sprintf($tooltip || "Persistenter Link auf %s", $reclabel));
return qq($visible);
}
END_OF_FUNC
'procFeedBack' => <<'END_OF_FUNC',
sub procFeedBack {
return '#ee[e#' unless defined $_[0];
my ($featref, $id, $reclabel) = @_;
return "" unless $id;
$reclabel ||= "diesem Datensatz";
my ($mailto, $label, $tooltip, $icon, $schmpat, $subjpat, $bodypat) = @$featref;
return unless $mailto;
$schmpat ||= "mailto:%4\$s";
$subjpat ||= "Anmerkung $::DbLabel: %2\$s";
$bodypat ||= "Guten Tag,\n\nzu %3\$s < %1\$s > folgendes:\n";
my $normid = NormalizeId($id);
my $permprefix = $::Features{'PermaLink'}->[0] || $Pop;
$permprefix .= "?t_".($::USE_Frames ? "tunnel=idn&" : "")."idn=%s";
##Populo 1.2x: my $permurl = sprintf(HtmEsc($urlpattern), urlescape($normid));
my $permurl = HtmEsc(sprintf($permprefix, urlescape($normid)));
my $url = urlescape(sprintf($schmpat, $permurl, $id, $reclabel, $mailto));
$url .= "?subject=" . urlescape(sprintf($subjpat, $permurl, $id, $reclabel, $mailto));
$url .= "&body=" . urlescape(sprintf($bodypat, $permurl, $id, $reclabel, $mailto));
$url = HtmEsc($url);
$label = Htm(sprintf($label || "Feedback", $reclabel));
my $visible = $icon ? qq!! : qq!$label!;
$tooltip = Htm(sprintf($tooltip || "Anmerkung zu %s", $reclabel));
return qq($visible);
}
END_OF_FUNC
'SetJobAndSub' => <<'END_OF_FUNC',
sub SetJobAndSub { # aehnliche Restriktionen wie in &dealwithjobtyp
return('#e#') unless defined $_[0];
local($_) = @_;
return 0 unless $_;
tr[0-9A-Za-z_/.\-][!]c; # sehr restriktiv!
s/\.[xy]$//; # falls graphischer Submit-Button...
if ( /^([^_]+)(?:_(.+))?$/ ) {
$JobTyp = $1;
$JobSubtyp = $2 || "";
return 1;
}
return 0; # failure
}
END_OF_FUNC
'NavLeiste' => <<'END_OF_FUNC',
sub NavLeiste {
return('#eee#') unless defined $_[0];
my ($position, $window, $recnums) = @_;
my @recnums = split(/\,/, $recnums);
my $recanz = $#recnums +1;
my $last = int($#recnums / $window) +1;
my $result = "";
if ( $position != 1 ) {
$result .= <<"XxX";
[Start]
[Zurück]
XxX
}
else {
};
my $i;
foreach $i ( ($position -4) .. ($position +4) ) {
next if $i < 1;
last if $i >$last;
my $von = ($i -1) * $window +1;
my $bis = $von + $window -1;
$bis = $recanz if $bis > $recanz;
$result .= ($i == $position)
? "[${von}-${bis}] "
: "[${von}-${bis}] ";
};
if ( $position != $last ) {
$result .= <<"XxX";
[Vorwärts]
[Ende]
XxX
}
else {
}
$result =~ s/\n//g; # prohibit breaks
return $result;
}
END_OF_FUNC
'AbbrInit' => <<'END_OF_FUNC',
%::Abbrs = (
'a.M' => 'Am Main',
'Abb' => 'Abbildung',
'Abh' => 'Abhandlung',
'Abk' => 'Abkürzung',
'Abschn' => 'Abschnitt',
'Abt' => 'Abteilung',
'Adr' => 'Adresse, Adressat',
'Akad' => 'Akademie',
'allg' => 'allgemein',
'Anm' => 'Anmerkung(en)',
'Anstr' => 'Anstreichung(en)', # EvB
'Art' => 'Artikel',
'Aufl' => 'Auflage',
'Aufz' => 'Aufzeichnung',
'Ausg' => 'Ausgabe',
'Ausw' => 'Auswahl',
'Ausz' => 'Auszug',
'Autogr' => 'Autograph',
'B' => '(Emil von) Behring', # EvB
'Bd' => 'Band',
'Bearb' => 'Bearbeiter, Bearbeitung',
'bearb' => 'bearbeitet',
'Beil' => 'Beilage',
'Bem' => 'Bemerkung(en)', # EvB
'bes' => 'besonders',
'Beschr' => 'Beschriftung', # EvB
'betr' => 'betreffend',
'Bl' => 'Blatt',
'Br' => 'Brief',
'bzw' => 'beziehungsweise',
'ca' => 'circa',
'd.h' => 'das heisst',
'd. h.' => 'das heißt', # EvB
'Dep' => 'Depositum',
'Diss' => 'Dissertation',
'Dr' => 'Druck, Doktor', # EvB
'ed' => 'ediert',
'Ed' => 'Edition',
'eh' => 'eigenhändig',
'ehem' => 'ehemalig',
'eingel' => 'eingelegt(es)', # EvB
'Eintr.' => 'Eintragung(en)', # EvB
'enth' => 'enthält',
'Entw' => 'Entwurf', # EvB
'erg' => 'ergänzt',
'Erg' => 'Ergänzung',
'Erl' => 'Erläuterung(en)', # EvB
'ersch' => 'erschienen',
'erw' => 'erweitert',
'ev' => 'evangelisch',
'evtl' => 'eventuell', # EvB
'Ex' => 'Exemplar',
'Exz' => 'Exzerpt', # EvB
'Faks' => 'Faksimile',
'faks' => 'faksimiliert',
'Fak' => 'Fakultät',
'farb' => 'farbig', # EvB
'Fasz' => 'Faszikel',
'fortlfd' => 'fortlaufend', # EvB
'Forts' => 'Fortsetzung',
'Fragm' => 'Fragment',
'fragm' => 'fragmentarisch',
'fr. Hd' => 'fremde(r) Hand', # EvB
'gbd' => 'gebunden', # EvB
'geb' => 'geboren',
'gedr' => 'gedruckt',
'geh' => 'geheftet', # EvB
'gegr' => 'gegründet',
'Ges' => 'Gesellschaft',
'gest' => 'gestorben',
'gez' => 'gezählt',
'gr' => 'groß',
'H' => 'Heft',
'Habil' => 'Habilitation',
'Hekt' => 'Hektographie', # EvB
'Hg' => 'Herausgeber',
'hg' => 'herausgegeben',
'Hs' => 'Handschrift(en)',
'hs' => 'handschriftlich(en)',
'i. A.' => 'im Auftrag', # EvB
'i.Br' => 'im Breisgau',
'Ill' => 'Illustration(en)', # EvB
'Inst' => 'Institut',
'internat' => 'international',
'J' => 'Jahr',
'Jg' => 'Jahrgang',
'Jh' => 'Jahrhundert',
'k.A' => 'keine Angabe(n)', # EvB
'Kap' => 'Kapitel',
'kath' => 'katholisch',
'Kl' => 'Klasse',
'kl' => 'klein',
'komp' => 'komponiert',
'Konv' => 'Konvolut',
'Korr' => 'Korrektur', # EvB
'lfd' => 'laufend',
'Lit' => 'Literatur',
'luth' => 'lutherisch',
'm' => 'mit',
'Mp' => 'Mappe',
'Ms' => 'Manuskript',
'masch' => 'maschinenschriftlich',
'math' => 'mathematisch',
'med' => 'medizinisch',
'Misz' => 'Miszellaneen',
'Mitarb' => 'Mitarbeiter',
'Mitt' => 'Mitteilung',
'Nachf' => 'Nachfolger',
'Nachl' => 'Nachlass',
'nachtägl' => 'nachträglich(en)', # EvB
'Nr' => 'Nummer',
'o.D' => 'ohne Datum',
'o.J' => 'ohne Jahr',
'o.O' => 'ohne Ort',
'o.O.u.J' => 'ohne Ort und Jahr',
'o.U' => 'ohne Unterschrift',
'Orig' => 'Original', # EvB
'Portr' => 'Portrait', # EvB
'Postskr' => 'Postskriptum',
'Postkt' => 'Postkarte(n)', # EvB
'Progr' => 'Programm',
'Pseud' => 'Pseudonym',
'r' => 'recto',
'Red' => 'Redaktion',
'Reg' => 'Register',
'rez' => 'rezensiert',
'Rez' => 'Rezension',
'S' => 'Seite(n)',
's' => 'siehe',
's/w' => 'schwarz/weiß', # EvB (geht nicht)
's.a' => 'siehe auch',
'Sign' => 'Signatur',
'Slg' => 'Sammlung',
'SoSe' => 'Sommersemester',
'Sp' => 'Spalte',
'St' => 'Stück',
'Tab' => 'Tabelle',
'teilw' => 'teilweise',
'Telegr' => 'Telegramm(e)', # EvB
'Transkr' => 'Transkription', # EvB
'Ts' => 'Typoskript(e)',
'Typoskr' => 'Typoskript', # EvB
'u' => 'und',
'u.a' => 'und andere, unter anderem',
'u.ä' => 'und ähnliche(s)',
'überarb' => 'überarbeitet',
'Übers' => 'Übersetzer, Übersetzung',
'überw' => 'überwiegend',
'u.d.T' => 'unter dem Titel', # EvB / RAK
'Umschl' => 'Umschlag', # EvB
'unbearb' => 'unbearbeitet',
'ungez' => 'ungezählt',
'Univ' => 'Universität',
'unterschiedl' => 'unterschiedlich', # EvB
'Unterstr' => 'Unterstreichung', # EvB
'Unterz' => 'Unterzeichner', # ThB
'unvollst' => 'unvollständig', # EvB
'usw' => 'und so weiter',
'v' => 'von, verso',
'verb' => 'verbessert',
'Verf' => 'Verfasser',
'Verl' => 'Verlag', # EvB
'vermutl' => 'vermutlich', # EvB
'vervielf' => 'vervielfältigt', # EvB
'Verz' => 'Verzeichnis',
'vgl' => 'vergleiche',
'vollst' => 'vollständig',
'vhd' => 'vorhanden',
'vorm' => 'vormalig, vormals',
'Vordr' => 'Vordruck', # EvB
'Vorw' => 'Vorwort',
'Widm' => 'Widmung', # EvB
'Wiss' => 'Wissenschaft',
'wiss' => 'wissenschaftlich',
'WS' => 'Wintersemester',
'z. B.' => 'zum Beispiel', # EvB
'z.B' => 'zum Beispiel',
'z. T.' => 'zum Teil', # EvB
'zahlr' => 'zahlreich',
'Zeichn' => 'Zeichnung(en)', # EvB
'Zeitschr' => 'Zeitschrift(en)', # EvB
'zugl' => 'zugleich',
);
sub AbbrInit {
return('#e#') unless defined $_[0];
$::AbbrRE = join("|", map{quotemeta} reverse sort keys %::Abbrs);
return 0;
}
END_OF_FUNC
#### Folgende fuer Populo v1.1x benoetigt, in v1.2x im Core enthalten
'QueryParse' => <<'END_OF_FUNC',
sub QueryParse {
PopDebug->Mess("Search String: $_\n") if $Debug;
my ($andlist, $orlist, $notlist) = ([], [], []);
my ($usestops) = @_;
tr/,./ /s; # vorab alle Anfuehrungen und loeschen
# s/^\s?(AND|UND|AND NOT|UND NICHT|OR|ODER|OR NOT|ODER NICHT|NOT|NICHT)\s//;
s/^\s//g; s/\s$//g; s/\s+/ /g; # Spatien
my @words = split (/ /, $_);
my $collecting = "";
my $collect;
my $whatlist = $andlist;
while ( @words ) { # naechster Durchlauf regulaer: $whatlist wird $andlist
# also mit next erzwingen, falls $whatlist gesetzt wird
$_ = shift @words;
next unless defined $_;
next if $_ eq "";
if ( $collecting ) {
if ( s/($collecting)$// ) {
$collect .= " $_" if $_;
push (@$whatlist, $collect.'?');
$collecting = "";
}
else {
tr/"//d;
$collect .= " $_";
next;
}
}
elsif ( /^([\'\"])(.+)?\1$/ ) {
push (@$whatlist, $2) if defined $2}
elsif ( s/^([\'\"])// ) {
$collecting = quotemeta($1);
$collect = $_;
next;
}
elsif ( /^AND$/ ) {
if ( $words[0] =~ /^NOT$/ ) {
$whatlist = $notlist;
shift @words;
next;
}
}
elsif ( /^UND$/ ) {
if ( $words[0] =~ /^NICHT$/ ) {
$whatlist = $notlist;
shift @words;
next;
}
}
elsif ( /^OR$/ ) {
$whatlist = $orlist;
if ( $words[0] =~ /^NOT$/ ) {
shift @words;
push (@$whatlist, "!ILLEGAL!");
}
next;
}
elsif ( /^ODER$/ ) {
$whatlist = $orlist;
if ( $words[0] =~ /^NICHT$/ ) {
shift @words;
push (@$whatlist, "!ILLEGAL!");
}
next;
}
elsif ( /^(NOT|NICHT)$/ ) {
$whatlist = $notlist}
elsif ( $usestops && s/^($Stopwords)(\'|$)//io ) {
push (@$whatlist, $_) if $_ ne ""}
elsif ( s/^\w'//i ) {
push (@$whatlist, $_) if $_ ne ""}
elsif ( /^.$/io ) { # Einzelzeichen
}
else {
s/[.,:!'"]+$//; s/^[.,:!]+//; # staerker normieren
push (@$whatlist, $_);
};
$whatlist = $andlist;
}
push (@$whatlist, $collect.'?') if $collecting; # schliessendes " hat also gefehlt...
$_ = "";
if ( @$andlist ) {
PopDebug->Mess("andlist: @$andlist\n") if $Debug;
$_ = join(" AND ", map{ qq(XxX-Reg-XxX "$_") } @$andlist);
};
if ( @$orlist ) {
PopDebug->Mess("orlist: @$orlist\n") if $Debug;
$_ = " ( $_ ) " if $_;
$_ .= join("", map { qq(OR XxX-Reg-XxX "$_") } @$orlist);
};
if ( @$notlist ) {
PopDebug->Mess("notlist: @$notlist\n") if $Debug;
# $_ = "!ILLEGAL!" unless $_;
$_ = " ( $_ ) " if $_;
$_ .= join("", map { qq(NOT XxX-Reg-XxX "$_") } @$notlist);
};
PopDebug->Mess("Result String: $_\n") if $Debug;
return $_;
}
END_OF_FUNC
'TextOrFile' => <<'END_OF_FUNC',
sub TextOrFile { # Variable oder referenzierte Datei einsetzen
return('#e#') unless defined $_[0];
local($_) = @_;
if ( /\s/ ) {
eval qq<\$_ = qq\x01$_\x01>;
PopDebug->Mess("$_ => $@") if $@;
return $_;
}
s!\\!/!g;
unless ( /^[\w\-.]+$/ ) {
PopDebug->Mess("Not accepting |$_| as name of file to include");
return $_;
};
PopDebug->ShowLoad("Looking for file $_ in @pathpraefixe\n");
my $praefix;
foreach $praefix ( @pathpraefixe ) {
if ( -r "$praefix$_" ) {
PopDebug->ShowLoad("Including $praefix$_\n");
if ( open(FRAG, "<$praefix$_") ) {
local($/) = undef;
my $slurp = ;
close(FRAG);
eval qq<\$_ = qq\x01$slurp\x01>;
PopDebug->Mess("$slurp => $@") if $@;
return $_;
}
else {
PopDebug->Mess("failed to open $praefix$_ for insertion")}
}
}
PopDebug->Mess("could not find file $_ for insertion");
return $_;
}
END_OF_FUNC
#### Folgende fuer Populo v1.1x benoetigt, in v1.2x im Core enthalten
'win2sor' => <<'END_OF_FUNC',
PopDebug->ShowLoad("Admin: &win2sor substituted by &iso2sor!\n");
sub win2sor {&iso2sor}
END_OF_FUNC
#### Folgende fuer Populo v1.1x benoetigt, ab v1.20_22 im Core enthalten
'Quote' => <<'END_OF_FUNC',
sub Quote { # zusammensetzen und quotieren
return('#e+#') unless defined $_[0];
local($_) = join("", @_);
return '"'.$_.'"' unless /"/;
return "'".$_."'" unless /'/;
s/"/" '"' "/g;
return '"'.$_.'"';
}
END_OF_FUNC
#### Datumsberechnung, aehnlich FormatTimeGM in Populo ab v1.20_19 und Future
'FormatTimeRel' => <<'END_OF_FUNC',
sub FormatTimeRel { # Perl-Zeiten (Sekunden ab 1970)
return('#e#') unless defined $_[0];
local($_) = @_;
my $pre = "";
s/^(.+: )// && ($pre = $1);
tr/ ,//d;
s/(\d+)m/+$1*60/g;
s/(\d+)h/+$1*3600/ig;
s/(\d+)d/+$1*86400/ig;
s/(\d+)w/+$1*604800/ig;
s/(\d+)M/+$1*2592000/g;
s/([\+\-])\+/$1/g;
if ( /^\d+$/ ) {}
elsif ( /^[\+\-][\d+\*\-]*\d+$/ ) {
$_ = eval($_) + time()}
else {
$_ = time()};
my($sec, $min, $hour, $mday, $mon, $year) = gmtime($_);
return $pre.sprintf("%04u-%02u-%02uT%02u:%02u:%02uZ", $year + 1900, $mon +1, $mday, $hour, $min, $sec);
}
END_OF_FUNC
#### Key beim Poke modifizieren (PokeIndirect waere uebertrieben)
'PokeStrip' => <<'END_OF_FUNC',
sub PokeStrip {
return '#beebe#' unless defined $_[0]; # Besser #beeee#?
my ($strucref, $prefix, $key, $labelwanted, $value) = @_;
($key =~ s/^\Q$prefix\E//) if $prefix;
return Poke($strucref, $key, $labelwanted, $value);
}
END_OF_FUNC
#### ReParse in Populo 1.2x enthalten
'ReParse' => <<'END_OF_FUNC',
sub ReParse { # erneutes Auswerten von PO!...!-Platzhaltern
return('#e#') unless defined $_[0];
local($_) = @_;
my $save = $_;
s/\!LI:([^!]+)\!([^!]+)\!/&lnkescp($1, $2)/eg;
Populo::Macros->Expand if /\<\?POPULO\s/;
s/PO\!(([^!"']+|"[^"]*"|'[^']*')+)\!/no strict 'vars'; eval((&parseval($1))[0])/ge;
PopDebug->Macros("ReParse:\t$save\n=>\t$_") if $_ ne $save;
# return (defined $_) ? $_ : "";
return $_;
}
END_OF_FUNC
# redirect to different NS
'PrintVariablesShort' => <<'END_OF_FUNC',
sub PrintVariablesShort {
return('#b#') unless defined $_[0];
&PopDebug::PrintVariablesShort("::".$_[0]);
};
END_OF_FUNC
);
#END_OF_AUTOLOAD
}
#
# Abschluss
#
# wir rufen selber auf (und raten wie wir heissen)
$Db = $ENV{'SCRIPT_FILENAME'} || $ENV{'SCRIPT_NAME'} || $0 || 'evb';
$Db =~ /[\\\/]([^\\\/]+)$/ && ($Db = $1);
$Db =~ s/\.(pl|plx|cgi)$//i;
if ( $Debug ) {
eval qq! require ("populo.pl"); ! || print $@}
else {
require ("populo.pl")}; # oder der heutige Name von Populo
################################################ Bootstrap code for Populo::OAI ###########
package Populo::OAI;
use strict;
sub Boot {
$Populo::OAI::Enable = 1 unless defined $Populo::OAI::Enable;
*AUTOLOAD = \&Populo::AUTOLOAD;
Populo::DelayPackage("popoai.pm", __PACKAGE__, qw(OAISetup));
}
sub dummy { &AUTOLOAD; }
1;