#!/usr/bin/perl -W
#--------------------------------------------------------------
# This example PERL script:
# - calls the GID_SL program from http://x-server.gmca.aps.anl.gov/
# - gets and saves the data.
# - the example is equivalent to the following page:
# http://x-server.gmca.aps.anl.gov/cgi/WWW_form.exe?template=GID_sl_multilay.htm
#
# PERL interpreter is available by default on UNIX and MAC OS. Freeware
# PERL distibution for Windows can be installed either as a part of Cygwin
# (http://www.cygwin.com), or as a standalone package available from
# ActiveState (http://www.activestate.com/).
#
# To access data from remote web site, this script makes use of PERL LWP
# module (WWW library for Perl). The latter is usually a part of standard
# PERL distribution; otherwise it can be freely downloaded from CPAN
# (http://www.cpan.org/).
#
# This example script can be freely distributed and modified without any
# restrictions.
#
#     		Author: Sergey Stepanov
#
# Version-1.1:  2006/11/08
#--------------------------------------------------------------
  use strict;
  use LWP::Simple;	# World-Wide Web library for Perl (libwww-perl)

### General parameters:
  my $url      = "http://x-server.gmca.aps.anl.gov";
  my $prg      = "${url}/cgi/GID_form.exe?";
  my $unzip    = "${url}/cgi/WWWunzip.exe?";
  my $comment1 = "Template: Perl script";

### X-rays:
  my $xway     = 1;	    # 1 - wavelength, 2 - energy, 3 - line type
  my $wave     = 1.540562;  # works with xway=2 or xway=3
# my $line     = "Cu-Ka1";  # works with xway=3 only
  my $line     = '';	    # works with xway=3 only
  my $ipol     = 1;	    # 1=sigma-polarization; 2=pi-polarization 3=mixed

### Substrate:
  my $code     = 'GaAs';    # crystal code
  my $w0       = 1.;        # Debye-Waller type correction for x0
  my $wh       = 1.;        # Debye-Waller type correction for xh
  my $daa      = 0.;        # substrate strain da/a
  my $sigma    = 0.;        # rms roughness at surface (Angstrom)

### Database Options for dispersion corrections df1, df2:
### -1 - Automatically choose DB for f',f"
###  0 - Use X0h data (5-25 keV or 0.5-2.5 A) -- recommended for Bragg diffraction.
###  2 - Use Henke data (0.01-30 keV or 0.4-1200 A) -- recommended for soft x-rays.
###  4 - Use Brennan-Cowan data (0.03-700 keV or 0.02-400 A)
  my $df1df2   = -1;

### Bragg reflection:
  my @hkl      = (4, 0, 0);

### Geometry specification:
### 1: Surface orientation & incidence angle of K0
### 2: Surface orientation & exit angle of Kh
### 3: Surface orientation & condition of coplanar grazing incidence
### 4: Surface orientation & condition of coplanar grazing exit
### 5: Surface orientation & condition of symmetric Bragg case
### 6: Condition of coplanar reflection & angle of Bragg planes to surface
### 7: Condition of coplanar reflection & incidence angle of K0
### 8: Condition of coplanar reflection & exit angle of Kh
### 9: Condition of coplanar reflection & asymmetry factor beta=g0/gh
  my $igie     = 5;	    # minimum scan angle (range)
### Geometry parameter:
### - incidence angle for [1,7],
### - exit angle for [2,8],
### - Bragg planes angle for [6],
### - asymmetry factor beta=g0/gh for [9].
  my $fcentre  = "";
  my $unic     = 0;         #fcentre units: 0=none/degr,1=min,2=mrad,3=sec,4=urad

### Crystal surface (used with geometry modes 1-5 only):
  my @n_hkl  = (1, 0, 0);   # base plane indices of surface
  my @m_hkl  = (0, 1, 1);   # indices of miscut direction
  my $miscut = 0.;          # miscut angle of surface with respect to $n_hkl
  my $unim   = 0;           # miscut units: 0=degr,1=min,2=mrad,3=sec,4=urad

### Scan axis:
### 1: Along surface normal (N_surface)
### 2: Along [k0 x N_surface] (vector product)
### 3: Along Reciprocal lattice vector (h)
### 4: Along [k0 x h] (vector product)
### 5: Along Other axis
### 6: Takeoff spectrum (PSD)
  my $axis   = 4;
  my @a_hkl  = (0, 0, 0);   # indices of "other" axis, if selected
  my $invert = 0;           # 1=invert axis, 0=don't invert

### Scan limits:
  my $scanmin  = -2000.;    # minimum scan angle (range)
  my $scanmax  =  2000.;    # maximum scan angle (range)
  my $unis     = 3;         # scan angle units: 0=degr.,1=min,2=mrad,3=sec,4=urad
  my $nscan    = 401;       # number of scan points
  my $column   = "I";       # A="scan angle", I="incidence angle", E="exit angle"

### Approximations:
  my $alphamax = 1.E+8;     # maximum alpha/|xh| when crystal considered "crystal"

### Surface layer profile
### (can also be read from
## a filename specified in
### the command line):
  my $profile = "
period=20
t=100 code=GaAs sigma=2
t=70 code=AlAs sigma=2 da/a=a
end period
";

### Encode strings that may contain illegal characters for CGI:
  $comment1 = &encode_url_string($comment1);
  $line     = &encode_url_string($line);
  $code     = &encode_url_string($code);
  $profile  = &encode_url_string($profile);
#-----------------------------------------------------------
### Submit task:
  my $address=${prg}.
            "comment1=${comment1}".
	    "&xway=${xway}".
            "&wave=${wave}".
            "&line=${line}".
            "&ipol=${ipol}".
            "&code=${code}".
            "&w0=${w0}".
            "&wh=${wh}".
            "&daa=${daa}".
            "&sigma=${sigma}".
            "&df1df2=${df1df2}".
	    "&i1=".$hkl[0]."&i2=".$hkl[1]."&i3=".$hkl[2].
            "&igie=${igie}".
            "&fcentre=${fcentre}".
            "&unic=${unic}".
	    "&n1=".$n_hkl[0]."&n2=".$n_hkl[1]."&n3=".$n_hkl[2].
	    "&m1=".$m_hkl[0]."&m2=".$m_hkl[1]."&m3=".$m_hkl[2].
            "&miscut=${miscut}".
            "&unim=${unim}".
            "&axis=${axis}".
	    "&a1=".$a_hkl[0]."&a2=".$a_hkl[1]."&a3=".$a_hkl[2].
            "&invert=${invert}".
            "&scanmin=${scanmin}".
            "&scanmax=${scanmax}".
            "&unis=${unis}".
            "&nscan=${nscan}".
            "&column=${column}".
            "&alphamax=${alphamax}".
            "&profile=${profile}";

### Request X0h data from the server:
  print STDOUT "Request string:\n${address}\n";
  my $buffer = get($address);
  $buffer =~ s/[\015\012]//g;		# remove CR/LF

### Find job ID on the server:
  my $jobID = $buffer;
  if ( $buffer =~ /Download ZIPped results:/ ) {
### Remove all text before and after job name in the string like:
### Download ZIPped results: <A HREF="/x-ray/GIDxxxxx.zip">GIDxxxxx.zip</A>
    $jobID =~ s/^.*Download ZIPped results: <A HREF=\"\/x-ray\///;
    $jobID =~ s/\.zip.*$//;
  } else {
    die "Unexpected completion, no job ID found\n";
  }

  my $error_text  = "/images/stop.gif";
  my $status = 0;

### Analyze server response and download the data:
  if ($buffer =~ /${error_text}/ ) {
### Erroneous completion:
     print STDOUT "Request was unsuccessfull, job ID=${jobID}\n";
     $buffer =~ s/^.*${error_text}//;	# remove all before error message
     $buffer =~ s/^.*<font size=\+1>//;	# remove all before error message
     $buffer =~ s/<\/font>.*$//;	# remove all after  error message
     $buffer =~ s/<br>/\n/g;		# replace HTML tags
     $buffer =~ s/\&nbsp;/ /g;		# replace HTML tags
     print STDOUT "Saving log: ${jobID}.tbl\n";
     &getstore("${unzip}jobname=${jobID}&filext=TBL","${jobID}.tbl");
     print STDOUT "\nERROR message:\n${buffer}\n";
     $status = 1;
  }
  else {
### Normal completion:
     print STDOUT "Request was successfull, job ID=${jobID}\n";
     if ( $buffer =~ /Display DAT file/ ) {
        $status = &getcheckstore($unzip,$jobID,"dat");
     } else {
	$status = 1;			# no data
     }
  }

  print STDOUT "Saving packed results: ${jobID}.zip\n";
  &getstore("${url}/x-ray/${jobID}.zip","${jobID}.zip");
  print STDOUT "Done!\n";
  exit $status;

############################################################################

#sub encode_url_string ($);
sub encode_url_string {
    my $KeepUnencoded  = 'a-zA-Z 0-9_\\-@.=';
    my ($toencode) = @_;
### ord - find a character's numeric representation
### "^": if not in the Unencoded list
    $toencode=~s/([^$KeepUnencoded])/sprintf("%%%02X",ord($1))/ego;
### Change spaces to "+":
    $toencode=~s/ /+/gm;
    return $toencode;
}

############################################################################

#sub getcheckstore ($$$);
sub  getcheckstore {
  my $unzip   = shift(@_);
  my $prefix  = shift(@_);
  my $ext     = shift(@_);
  print STDOUT "Saving data: ${prefix}.${ext}\n";
  my $data = get("${unzip}jobname=${prefix}&filext=${ext}");
  $data =~ s/\015//g;			# Perl for Windows workaround
  if ( $data =~ /stop/ ) {		# stop1.gif is returned when no data
     print STDOUT "!!! No data on server!\n";
     return 1;
  } else {
     open (DAT,"> ${prefix}.${ext}") or die "Cannot open ${prefix}.${ext}";
     print DAT ${data};
     close(DAT);
     return 0;
  }
}

############################################################################