#!/usr/bin/perl # Copyright René Wagner 2020 # licenced under BSD 3-Clause licence # https://src.clttr.info/rwa/orrg package orrg; use strict; use Exporter; our @ISA = qw(Exporter); our @EXPORT = qw(popular_get popular_add recent_get recent_add write_response %RC); # automatically exported subs # enable UTF-8 mode for everything use utf8; binmode STDOUT, ':utf8'; binmode STDERR, ':utf8'; my $recentfile = 'data/recent.txt'; my $popularfile = 'data/popular.txt'; # define return codes our %RC = ( 'INPUT', 10, 'SENSITIVE_INPUT', 11, 'SUCCESS', 20, 'TEMPORARY_REDIRECT', 30, 'PERMANENT_REDIRECT', 31, 'TEMPORARY_FAILURE', 40, 'SERVER_UNAVAILABLE', 41, 'CGI_ERROR', 42, 'PROXY_ERROR', 43, 'SLOW_DOWN', 44, 'PERMANENT_FAILURE', 50, 'NOT_FOUND', 51, 'GONE', 52, 'PROXY_REQUEST_REFUSE', 53, 'BAD_REQUEST', 59, 'CLIENT_CERT_REQUIRED', 60, 'CERT_NOT_AUTHORISED', 61, 'CERT_NOT_VALID', 62 ); sub recent_get { (-f $recentfile) or return undef; my @recents = (); open INFILE, '< :encoding(UTF-8)', $recentfile; flock INFILE, 1; while () { chomp($_); push @recents, $_; } flock INFILE, 8; close INFILE; return \@recents; } sub recent_add { my ( $uri, $name ) = @_; my $recent = recent_get(); my $newline = "$uri $name"; open OUTFILE, '> :encoding(UTF-8)', $recentfile; flock OUTFILE, 1; print OUTFILE "$newline\n"; my $c = 1; foreach (@$recent) { if ($newline ne $_) { print OUTFILE "$_\n"; $c++; } ($c < 10) or last; } flock OUTFILE, 8; close OUTFILE; } sub popular_get { (-f $popularfile) or return undef; my @populars = (); open INFILE, '< :encoding(UTF-8)', $popularfile; flock INFILE, 1; while () { chomp($_); push @populars, $_; } flock INFILE, 8; close INFILE; return \@populars; } sub popular_add { my ( $uri, $name ) = @_; my $populars = popular_get(); open OUTFILE, '> :encoding(UTF-8)', $popularfile; flock OUTFILE, 1; my $found = 0; foreach (@$populars) { my ($cnt, $popuri, $popname) = split / /, $_, 3; if ($uri eq $popuri) { $cnt++; $found = 1; } print OUTFILE "$cnt $popuri $popname\n"; } $found or print OUTFILE "1 $uri $name"; flock OUTFILE, 8; close OUTFILE; } sub write_response { my ($returncode, $meta, @content) = @_; defined($RC{$returncode}) or die "Unknown response code!"; printf("%d %s\r\n", $RC{$returncode}, ($meta eq '') ? $returncode : $meta); foreach (@content) { print("$_\r\n"); } exit; } 1;