<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">package OpenILS::WWW::Exporter;
use strict;
use warnings;
use bytes;

use Apache2::Log;
use Apache2::Const -compile =&gt; qw(OK REDIRECT DECLINED NOT_FOUND :log);
use APR::Const    -compile =&gt; qw(:error SUCCESS);
use APR::Table;

use Apache2::RequestRec ();
use Apache2::RequestIO ();
use Apache2::RequestUtil;
use CGI;
use Data::Dumper;
use Text::CSV;

use OpenSRF::EX qw(:try);
use OpenSRF::Utils qw/:datetime/;
use OpenSRF::Utils::Cache;
use OpenSRF::System;
use OpenSRF::AppSession;
use XML::LibXML;
use XML::LibXSLT;

use Encode;
use Unicode::Normalize;
use OpenILS::Utils::Fieldmapper;
use OpenSRF::Utils::Logger qw/$logger/;

use MARC::Record;
use MARC::File::XML;

use UNIVERSAL::require;

our @formats = qw/USMARC UNIMARC XML BRE/;

# set the bootstrap config and template include directory when
# this module is loaded
my $bootstrap;

sub import {
        my $self = shift;
        $bootstrap = shift;
}


sub child_init {
        OpenSRF::System-&gt;bootstrap_client( config_file =&gt; $bootstrap );
}

sub handler {
	my $r = shift;
	my $cgi = new CGI;

	# find some IDs ...
	my @records;

	@records = map { $_ ? ($_) : () } $cgi-&gt;param('id');

	if (!@records) { # try for a file
		my $file = $cgi-&gt;param('idfile');
		if ($file) {
			my $col = $cgi-&gt;param('idcolumn') || 0;
			my $csv = new Text::CSV;

			while (&lt;$file&gt;) {
				$csv-&gt;parse($_);
				my @data = $csv-&gt;fields;
				my $id = $data[$col];
				$id =~ s/\D+//o;
				next unless ($id);
				push @records, $id;
			}
		}
	}

	if (!@records) { # try pathinfo
		my $path_rec = $cgi-&gt;path_info();
		if ($path_rec) {
			@records = map { $_ ? ($_) : () } split '/', $path_rec;
		}
	}

	my $ses = OpenSRF::AppSession-&gt;create('open-ils.cstore');

	# still no records ...
	my $container = $cgi-&gt;param('containerid');
	if ($container) {
		my $bucket = $ses-&gt;request( 'open-ils.cstore.direct.container.biblio_record_entry_bucket.retrieve', $container )-&gt;gather(1);
        unless($bucket) {
            $r-&gt;log-&gt;error("No such bucket $container"); 
            $logger-&gt;error("No such bucket $container"); 
            return Apache2::Const::NOT_FOUND;
        }
        if ($bucket-&gt;pub !~ /t|1/oi) {
    		my $authid = $cgi-&gt;cookie('ses') || $cgi-&gt;param('ses');
	    	my $auth = verify_login($authid);
		    if (!$auth) {
			    return 403;
    		}
        }
		my $recs = $ses-&gt;request( 'open-ils.cstore.direct.container.biblio_record_entry_bucket_item.search.atomic', { bucket =&gt; $container } )-&gt;gather(1);
		@records = map { ($_-&gt;target_biblio_record_entry) } @$recs;
	}

	return show_template($r) unless (@records);

	my $type = $cgi-&gt;param('rectype') || 'biblio';
	if ($type ne 'biblio' &amp;&amp; $type ne 'authority') {
		return 400;
	}

	my $tcn_v = 'tcn_value';
	my $tcn_s = 'tcn_source';

	if ($type eq 'authority') {
		$tcn_v = 'arn_value';
		$tcn_s = 'arn_source';
	}

	my $holdings = $cgi-&gt;param('holdings') if ($type eq 'biblio');
	my $location = $cgi-&gt;param('location') || 'gaaagpl'; # just because...

	my $format = $cgi-&gt;param('format') || 'USMARC';
	$format = uc($format);

	my $encoding = $cgi-&gt;param('encoding') || 'UTF-8';
	$encoding = uc($encoding);

	my $filename = $cgi-&gt;param('filename') || "export.$type.$encoding.$format";

	binmode(STDOUT, ':raw') if ($encoding ne 'UTF-8');
	binmode(STDOUT, ':utf8') if ($encoding eq 'UTF-8');

	if (!grep { uc($format) eq $_ } @formats) {
		return 400;
	}

	if ($format ne 'XML') {
		my $ftype = 'MARC::File::' . $format;
		$ftype-&gt;require;
	}


	$r-&gt;headers_out-&gt;set("Content-Disposition" =&gt; "inline; filename=$filename");

	if (uc($format) eq 'XML') {
		$r-&gt;content_type('application/xml');
	} else {
		$r-&gt;content_type('application/octet-stream');
	}

	$r-&gt;print( &lt;&lt;"	HEADER" ) if (uc($format) eq 'XML');
&lt;?xml version="1.0" encoding="$encoding"?&gt;
&lt;collection xmlns='http://www.loc.gov/MARC21/slim'&gt;
	HEADER

	my %orgs;
	my %shelves;
	my %statuses;

	my $flesh = {};
	if ($holdings) {

		my $req = $ses-&gt;request( 'open-ils.cstore.direct.actor.org_unit.search', { id =&gt; { '!=' =&gt; undef } } );

    		while (my $o = $req-&gt;recv) {
        		next if ($req-&gt;failed);
        		$o = $o-&gt;content;
        		last unless ($o);
	    		$orgs{$o-&gt;id} = $o;
    		}
    		$req-&gt;finish;

		$req = $ses-&gt;request( 'open-ils.cstore.direct.asset.copy_location.search', { id =&gt; { '!=' =&gt; undef } } );

    		while (my $s = $req-&gt;recv) {
        		next if ($req-&gt;failed);
        		$s = $s-&gt;content;
        		last unless ($s);
	    		$shelves{$s-&gt;id} = $s;
    		}
    		$req-&gt;finish;

		$req = $ses-&gt;request( 'open-ils.cstore.direct.config.copy_status.search', { id =&gt; { '!=' =&gt; undef } } );

    		while (my $s = $req-&gt;recv) {
        		next if ($req-&gt;failed);
        		$s = $s-&gt;content;
        		last unless ($s);
	    		$statuses{$s-&gt;id} = $s;
    		}
    		$req-&gt;finish;

    		$flesh = { flesh =&gt; 2, flesh_fields =&gt; { bre =&gt; [ 'call_numbers' ], acn =&gt; [ 'copies' ] } };
	}

	for my $i ( @records ) {
    		my $bib;
    		try {
        		local $SIG{ALRM} = sub { die "TIMEOUT\n" };
        		alarm(1);
	    		$bib = $ses-&gt;request( "open-ils.cstore.direct.$type.record_entry.retrieve", $i, $flesh )-&gt;gather(1);
        		alarm(0);
    		} otherwise {
        		warn "\n!!!!!! Timed out trying to read record $i\n";
    		};
    		alarm(0);

		next unless $bib;

    		if (uc($format) eq 'BRE') {
        		$r-&gt;print( OpenSRF::Utils::JSON-&gt;perl2JSON($bib) . "\n" );
        		next;
    		}

		try {

			my $req = MARC::Record-&gt;new_from_xml( $bib-&gt;marc, $encoding, $format );
			$req-&gt;delete_field( $_ ) for ($req-&gt;field(901));
			$req-&gt;encoding($encoding) if ($encoding eq 'UTF-8');

			$req-&gt;append_fields(
				MARC::Field-&gt;new(
					901, '', '', 
					a =&gt; $bib-&gt;$tcn_v,
					b =&gt; $bib-&gt;$tcn_s,
					c =&gt; $bib-&gt;id
				)
			);


			if ($holdings) {
        			my $cn_list = $bib-&gt;call_numbers;
        			if ($cn_list &amp;&amp; @$cn_list) {

            				my $cp_list = [ map { @{ $_-&gt;copies } } @$cn_list ];
            				if ($cp_list &amp;&amp; @$cp_list) {

	            				my %cn_map;
	            				push @{$cn_map{$_-&gt;call_number}}, $_ for (@$cp_list);
		                        
	            				for my $cn ( @$cn_list ) {
	                				my $cn_map_list = $cn_map{$cn-&gt;id};
	
	                				for my $cp ( @$cn_map_list ) {
		                        
								$req-&gt;append_fields(
									MARC::Field-&gt;new(
										852, '4', '', 
										a =&gt; $location,
										b =&gt; $orgs{$cn-&gt;owning_lib}-&gt;shortname,
										b =&gt; $orgs{$cp-&gt;circ_lib}-&gt;shortname,
										c =&gt; $shelves{$cp-&gt;location}-&gt;name,
										j =&gt; $cn-&gt;label,
										($cp-&gt;circ_modifier ? ( g =&gt; $cp-&gt;circ_modifier ) : ()),
										p =&gt; $cp-&gt;barcode,
										($cp-&gt;price ? ( y =&gt; $cp-&gt;price ) : ()),
										($cp-&gt;copy_number ? ( t =&gt; $cp-&gt;copy_number ) : ()),
										($cp-&gt;ref eq 't' ? ( x =&gt; 'reference' ) : ( x =&gt; 'nonreference' )),
										($cp-&gt;holdable eq 'f' ? ( x =&gt; 'unholdable' ) : ( x =&gt; 'holdable' )),
										($cp-&gt;circulate eq 'f' ? ( x =&gt; 'noncirculating' ) : ( x =&gt; 'circulating' )),
										($cp-&gt;opac_visible eq 'f' ? ( x =&gt; 'hidden' ) : ( x =&gt; 'visible' )),
										z =&gt; $statuses{$cp-&gt;status}-&gt;name,
									)
								);

							}
						}
					}
        			}
			}

			if (uc($format) eq 'XML') {
				my $x = $req-&gt;as_xml_record;
				$x =~ s/^&lt;\?xml version="1.0" encoding="UTF-8"\?&gt;//o;
				$r-&gt;print($x);
			} elsif (uc($format) eq 'UNIMARC') {
				$r-&gt;print($req-&gt;as_unimarc);
			} elsif (uc($format) eq 'USMARC') {
				$r-&gt;print($req-&gt;as_usmarc);
			}

            $r-&gt;rflush();

		} otherwise {
			my $e = shift;
			warn "\n$e\n";
		};

	}

	$r-&gt;print("&lt;/collection&gt;\n") if ($format eq 'XML');

	return Apache2::Const::OK;

}

sub verify_login {
        my $auth_token = shift;
        return undef unless $auth_token;

        my $user = OpenSRF::AppSession
                -&gt;create("open-ils.auth")
                -&gt;request( "open-ils.auth.session.retrieve", $auth_token )
                -&gt;gather(1);

        if (ref($user) eq 'HASH' &amp;&amp; $user-&gt;{ilsevent} == 1001) {
                return undef;
        }

        return $user if ref($user);
        return undef;
}

sub show_template {
	my $r = shift;

	$r-&gt;content_type('text/html');
	$r-&gt;print(&lt;&lt;HTML);

&lt;html&gt;
	&lt;head&gt;
		&lt;title&gt;Record Export&lt;/title&gt;
	&lt;/head&gt;
	&lt;body&gt;
		&lt;form method="POST" enctype="multipart/form-data"&gt;
			Use field number &lt;input type="text" size="2" maxlength="2" name="idcolumn" value="0"/&gt; (starting from 0)
			from CSV file &lt;input type="file" name="idfile"/&gt;
			&lt;br/&gt;&lt;br/&gt; &lt;b&gt;or&lt;/b&gt; &lt;br/&gt;&lt;br/&gt;
			Record ID &lt;input type="text" size="12" maxlength="12" name="id"/&gt;
			&lt;br/&gt;&lt;br/&gt; Record Type:
			&lt;select name="rectype"&gt;
				&lt;option value="biblio"&gt;Bibliographic Records&lt;/option&gt;
				&lt;option value="authority"&gt;Authority Records&lt;/option&gt;
			&lt;/select&gt;
			&lt;br/&gt; Record Format:
			&lt;select name="format"&gt;
				&lt;option value="USMARC"&gt;MARC21&lt;/option&gt;
				&lt;option value="UNIMARC"&gt;UNIMARC&lt;/option&gt;
				&lt;option value="XML"&gt;MARC XML&lt;/option&gt;
				&lt;option value="BRE"&gt;Evergreen BRE&lt;/option&gt;
			&lt;/select&gt;
			&lt;br/&gt; Record Encoding:
			&lt;select name="encoding"&gt;
				&lt;option value="UTF-8"&gt;UTF-8&lt;/option&gt;
				&lt;option value="MARC8"&gt;MARC8&lt;/option&gt;
			&lt;/select&gt;
			&lt;br/&gt; Include holdings in Bibliographic Records:
			&lt;input type="checkbox" name="holdings" value="1"&gt;
			&lt;br/&gt;&lt;br/&gt;&lt;input type="submit" value="Retrieve Records"/&gt;
		&lt;/form&gt;
	&lt;/body&gt;
&lt;/html&gt;

HTML

	return Apache2::Const::OK;
}

1;
</pre></body></html>