Katteregisteret

#!/usr/bin/perl #============================================================================== # KATTEREGISTER # # file: katteregister.pl # version: v0.31 # type: perl script # author: erik warendorph [ew] # date(s): 2003-03-28..2003-07-03..2003-08-28..2003-09-09..2003-09-11.. # 2003-09-16..2003-10-07..2003-10-30..2003-11-19..2003-11-20.. # 2003-12-10..2004-01-15..2004-01-20..2004-02-05..2004-02-27.. # 2004-04-01..2004-04-18..2004-05-14 # # description: # # - search in the cat register # - was earlier called register_katt.pl # #------------------------------------------------------------------------------ $| = 1; # pragmas use strict; # use the iso-latin-1 locale (for uc(), lc(), m//i, etc) use locale; use POSIX qw/locale_h/; #setlocale(LC_CTYPE, "en_US.ISO-8859-1"); setlocale(LC_CTYPE, "en_US"); # modules use CGI qw( :standard escapeHTML unescapeHTML ); # global variables use vars qw( $webroot $css_file $file $ssi_menu_file $maxhits $hi_begin $hi_end $master $fileupdate @pn %pn2f @fn_in @fn_out @fn_cat ); # init variables if (defined $ENV{SERVER_NAME} and $ENV{SERVER_NAME} =~ /\boffworld\.off\b/) { $webroot = "/home/ew/data/dn/www"; $css_file = "/~ew/dn.css"; } else { $webroot = "/home/dyrebesk/public_html"; $css_file = "../dn.css"; } $file = "$webroot/CGI_BIN/katteregister.txt.pl"; $ssi_menu_file = "$webroot/meny.shtml"; $maxhits = 100; #$hi_begin = ""; # light yellow #$hi_begin = ""; # cyan #$hi_begin = ""; # blue #$hi_begin = ""; # lighter yellow $hi_begin = ""; $hi_end = ""; $master = 0; @pn = qw( id dead name gender fixed race hair color zip city q ); %pn2f = ( id => "id", dead => "død", name => "navn", gender => "kjønn", fixed => "kastr-steril", race => "rase", hair => "hårlag", color => "farge-tegn", zip => "postnr", city => "poststed", ); @fn_in = ( "id", "død", "navn", "kjønn", "kastr-steril", "rase", "hårlag", "farge-tegn", "etternavn", "fornavn", "adresse", "postnr", "poststed", "e-post", "telefon 1", "telefon 2", "telefon 3", "tatovert", "veterinær", "notat", "opprettet", "oppretter", "endret", "endrer", ); @fn_out = ( "id", "død", "navn", "kjønn", "kastr-steril", "rase", "hårlag", "farge-tegn", "etternavn", "fornavn", "adresse", "postnr", "poststed", "e-post", "telefon 1", "telefon 2", "telefon 3", "tatovert", "veterinær", "notat", "opprettet", "oppretter", "endret", "endrer", ); @fn_cat = ( "id", "død", "navn", "kjønn", "kastr-steril", "rase", "hårlag", "farge-tegn", "postnr", "poststed", "tatovert", "veterinær", "notat", ); &main(); sub main { print header(); $fileupdate = &get_file_update($file); print &html_start(); # debug if (param() and param("debug")) { foreach (sort keys %ENV) { print "$_: $ENV{$_}
\n"; } } &check_password(); print &search_form(); if (param()) { print &result(); } print &html_end(); } sub html_start { my $o; local($_); $o = ""; $o .= < Katteregisteret EOF open(FH, "< $ssi_menu_file") or print "($ssi_menu_file: $!)
\n"; while () { $o .= $_; } close(FH); $o .= < EOF return $o; } sub get_file_update { my ($file) = $_[0]; my $mtime = ""; my @t = (); my $str = "(ikke tilgjengelig)"; if (-e $file) { $mtime = (stat($file))[9]; @t = localtime($mtime); $t[5] += 1900; # year $t[4]++; # month $str = sprintf("%04d.%02d.%02d %02d:%02d", $t[5], $t[4], $t[3], $t[2], $t[1]); } return $str; } sub check_password { if (defined(param("pw"))) { if (param("pw") eq "dn1859admin" or param("pw") eq "drowssap") { $master = 1; return 1; } } return 0; } sub search_form { my $p; # parameter my $pv; # parameter value my $o = ""; # fix whitespace in parameters foreach $p (@pn) { if (defined(param($p)) and length(param($p))) { $pv = param($p); $pv =~ s/^\s+//; # preceding whitespace $pv =~ s/\s+$//; # trailing whitespace $pv =~ s/\s+/ /g; # inner whitespace $pv =~ s/\s*\|\s*/|/g; # whitespace before and after "or" ("|") param($p, $pv); } } $o .= <

@{[ hidden("pw") ]} @{[ hidden("ul") ]} @{[ hidden("debug") ]} @{[ ($master)? "" : "" ]}

Katteregisteret Dyrebeskyttelsen Norges register over katter (og kaniner) med id-nummer tatovert i øret. Bruk *`` for å erstatte null eller flere tegn. Et søk på ``34, gir treff på 1234. Et søk på s``rt, gir treff på sort og svart**. Hjelp >>
id:	@{[ textfield(-name => "id", -size => 32) ]}
navn:	@{[ textfield(-name => "name", -size => 32) ]}
kjønn:	@{[ radio_group(-name => 'gender', -values => [ '', 'f', 'm' ], -default => '', -linebreak => 0, -labels => { '' => "ukjent", 'f' => "hunn", 'm' => "hann", }, ) ]}
kastr-steril:	@{[ radio_group(-name => 'fixed', -values => [ '', '1', '0' ], -default => '', -linebreak => 0, -labels => { '' => "ukjent", '1' => "ja", '0' => "nei", }, ) ]}
rase:	@{[ textfield(-name => "race", -size => 32) ]}
hårlag:	@{[ textfield(-name => "hair", -size => 32) ]}
farge-tegn:	@{[ textfield(-name => "color", -size => 32) ]}
postnr:	@{[ textfield(-name => "zip", -size => 32) ]}
poststed:	@{[ textfield(-name => "city", -size => 32) ]}
søk i alle felter:	@{[ textfield(-name => "q", -size => 32) ]}
	@{[ submit("submit", "Søk") ]} @{[ defaults("Nullstill") ]}
Oppdatert $fileupdate.

Andre register

Hunder med microchip kan være registrert hos Dyreidentitet AS eller NKK, eller begge steder.

Personell med microchip-avleser kan søke på dyrets id-nummer for å finne dyreeier, og dyreeiere kan søke på dyrets id-nummer for å kontrollere sin informasjon.

Dyreidentitet AS har register over dyr som er id-merket med microchip: Katter, hunder, hester, ildere, gnagere, eksotiske fugler og krypdyr, rovvilt og ville fugler.
Søk på id-nummer:

Norsk Kennel Klub har register over medlemshunder som er id-merket med microchip eller med id-nummer tatovert i øret eller lysken.

EOF return $o; } sub result { my $o = "";; my $p; my @pnu; # parameter names used my %regexp; my $regexp; my %f; # fields my $k; # key my @fn_q; # field names for q (freetext) my $txt; my $hit; my $n; @pnu = (); if ($master) { @fn_q = @fn_out; } else { @fn_q = @fn_cat; } # regexps foreach $p (@pn) { if (defined(param($p)) and param($p) =~ /\S/) { # radio button for dead if ($p eq "dead") { if (param($p) eq "1") { $regexp{$p} = [ qr/død/i ]; push(@pnu, $p); } elsif (param($p) eq "0") { # "hairy" (from the cookbook) $regexp{$p} = [ qr/^(?:(?!død).)*$/i ]; push(@pnu, $p); } } # radio button for gender elsif ($p eq "gender") { if (param($p) eq "f") { $regexp{$p} = [ qr/hun\S*/i ]; push(@pnu, $p); } elsif (param($p) eq "m") { $regexp{$p} = [ qr/han\S*/i ]; push(@pnu, $p); } } # radio button for fixed elsif ($p eq "fixed") { if (param($p) eq "1") { $regexp{$p} = [ qr/kast\S*|ster\S*/i ]; push(@pnu, $p); } elsif (param($p) eq "0") { # "hairy" (from the cookbook) $regexp{$p} = [ qr/^(?:(?!kast|ster).)*$/i ]; push(@pnu, $p); } } # text fields else { foreach (split(' ', param($p))) { $_ = quotemeta($_); s/\\\|/|/g; if ($p eq "zip" or $p eq "id") { s/\|/|^/g; } s/\\\?/\\S/g; s/\\\*/\\S*/g; if ($p eq "zip" or $p eq "id") { $_ = "^$_"; } if (length($_)) { push(@{$regexp{$p}}, qr/$_/i); } } push(@pnu, $p); } } } # debug if (param() and param("debug")) { foreach $p (@pnu) { if (defined($regexp{$p})) { print "param: $p
\n"; foreach (@{$regexp{$p}}) { print " - $_
\n"; } } } print "
\n"; } # no parameters filled in if (not %regexp) { return "

\n" . "

" . "Feilmelding: Ett eller flere felter må fylles ut." . "

"; } # loop thru file $n = 0; open(FH, "< $file") or print "($file: $!)
\n"; print "

Søker..........\n"; LINE: while() { last if (not $master and $n >= 100); s/[\x0D\x0A]+$//; (@f{@fn_in}) = split(/\t/, $_, -1); # test $hit = 1; foreach $p (@pnu) { if (defined($regexp{$p})) { # more than one fields for q (free text) if ($p eq "q") { # all fields for master if ($master) { $txt = $_; } # only cat fields for non-master else { $txt = join("\t", @f{@fn_cat}); } } # only one for other fields else { $txt = $f{$pn2f{$p}}; } # try all the regexps foreach $regexp (@{$regexp{$p}}) { if ($txt =~ /$regexp/) { # XXX mark up the string... well, that's done below } else { $hit = 0; next LINE; } } } } # do stuff when we've got a hit if ($hit) { $n++; # highlight matches for the ordinary parameters foreach $p (@pnu) { # skip the "q" parameter (dealt with below) next if $p eq "q"; # skip the parameters with "don't match" regexps next if $p eq "dead" and param("dead") == 0; next if $p eq "fixed" and param("fixed") == 0; if (defined($regexp{$p})) { foreach $regexp (@{$regexp{$p}}) { $f{$pn2f{$p}} =~ s/($regexp)/\x01$1\x02/g; } } } # highlight matches for the "q" parameter if ($regexp{q}) { foreach $k (@fn_q) { foreach $regexp (@{$regexp{q}}) { $f{$k} =~ s/($regexp)/\x01$1\x02/g; } } } # transform highlight control characters into html code foreach $k (@fn_out) { $f{$k} =~ s!\x01!$hi_begin!g; $f{$k} =~ s!\x02!$hi_end!g; } # make output $o .= join("", "\n", " Treff $n av \${tot_n}\n", "\n", ); foreach (@fn_out) { # if not master, don't include the following 4 fields if (not $master and /^(?: opprettet | oppretter | endret | endrer )$/x) { next; } # if not master, don't include the dead field for cats that aren't dead if (not $master and $_ eq "død" and $f{$_} !~ /død/) { next; } $txt = $f{$_}; $o .= join("", "\n", " ", #"$_: ", "$_: ", "\n", " ", #$f{$_}, $txt, "", "\n", ); } $o .= join("", "\n", "

\n", "\n", ); } } close(FH); # wrap output in table if (length($o)) { $o = join("", "\n", "\n", " \n", "\n", $o, "

\n", ); $o =~ s/\$\{tot_n\}/$n/g; } # output for no hits else { $o = ""; } print " $n treff

\n"; return $o; } #=== end-of-file: katteregister.pl ============================================ ====================