lib/SIP2/ACS.pm

   1 package SIP2::ACS;
   2
   3 =head1 NAME
   4
   5 SIP2::ACS - Automated Circulation System
   6
   7 =head1 DESCRIPTION
   8
   9 Basically just a simple proxy to real ACS server
  10
  11 =cut
  12
  13 use warnings;
  14 use strict;
  15
  16 use IO::Socket::INET;
  17 use IO::Select;
  18
  19 use Data::Dump qw(dump);
  20
  21 use lib 'lib';
  22 use SIP2::SC;
  23
  24 sub proxy {
  25         my ( $listen, $server ) = @_;
  26
  27         warn "listen on $listen for SIP2/RAW and connect to $server\n";
  28
  29         my $lsn = IO::Socket::INET->new(Listen => 1, LocalAddr => $listen, Reuse => 1) or die $!;
  30         my $sel = IO::Select->new($lsn);
  31
  32         my $sc;
  33
  34         local $/ = "\r";
  35
  36         while (1) {
  37                 for my $sock ($sel->can_read(1)) {
  38
  39                         if ($sock == $lsn) {
  40                                 my $new = $lsn->accept;
  41                                 my $ip = $sock->peerhost;
  42                                 warn "connection from $ip\n";
  43                                 $sel->add($new);
  44                         } else {
  45                                 my $line = <$sock>;
  46                                 if ( ! defined $line ) {
  47                                         warn "disconnect from ", $sock->peerhost;
  48                                         $sel->remove( $sock );
  49                                         delete( $sc->{$sock} );
  50                                         close($sock);
  51                                         next;
  52                                 }
  53                                 my $ip = $sock->peerhost;
  54                                 warn "<< $ip ", dump($line);
  55                                 if ( ! $sc->{$sock} ) {
  56                                         warn "connect to $server for $sock\n";
  57                                         $sc->{$sock} = SIP2::SC->new( $server );
  58                                 }
  59                                 $line .= "\n"; # lf to fix Koha ACS
  60                                 print $sock $sc->{$sock}->message( $line )
  61                         }
  62                 }
  63         }
  64 }
  65
  66 1;
  67