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 my $listen = '127.0.0.1:6001';
  25 my $server = '10.60.0.251:6001';
  26
  27 warn "listen on $listen for SIP2/RAW\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 our $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                         warn dump($sock);
  46                         my $line = <$sock>;
  47                         if ( ! defined $line ) {
  48                                 if ( ! $sock->connected ) {
  49                                         warn "disconnect from ", $sock->peerhost;
  50                                         $sel->remove( $sock );
  51                                         delete( $sc->{$sock} );
  52                                         close($sock);
  53                                         next;
  54                                 }
  55                                 warn "no data from ", $sock->peerhost;
  56                                 next;
  57                         }
  58                         my $ip = $sock->peerhost;
  59                         warn "<< $ip ", dump($line);
  60                         if ( ! $sc->{$sock} ) {
  61                                 warn "connect to $server for $sock\n";
  62                                 $sc->{$sock} = SIP2::SC->new( $server );
  63                         }
  64                         $line .= "\n"; # lf to fix Koha ACS
  65                         print $sock $sc->{$sock}->message( $line )
  66                 }
  67         }
  68 }
  69
  70 1;
  71