summaryrefslogtreecommitdiff
path: root/Master/texmf-dist/scripts/ctan-o-mat
diff options
context:
space:
mode:
authorKarl Berry <karl@freefriends.org>2017-11-16 22:15:27 +0000
committerKarl Berry <karl@freefriends.org>2017-11-16 22:15:27 +0000
commit26bbe6fbf6f01b0ad3162a5d7c2cc0a6fbaafc13 (patch)
tree062a4755a4137f13acd90b525b6cc5415f2e328a /Master/texmf-dist/scripts/ctan-o-mat
parentbdb7ac9c2d3d7ef690d7499162aa15f0b8e51d21 (diff)
ctan-o-mat (16nov17)
git-svn-id: svn://tug.org/texlive/trunk@45834 c570f23f-e606-0410-a88d-b1316a301751
Diffstat (limited to 'Master/texmf-dist/scripts/ctan-o-mat')
-rwxr-xr-xMaster/texmf-dist/scripts/ctan-o-mat/ctan-o-mat.pl574
1 files changed, 370 insertions, 204 deletions
diff --git a/Master/texmf-dist/scripts/ctan-o-mat/ctan-o-mat.pl b/Master/texmf-dist/scripts/ctan-o-mat/ctan-o-mat.pl
index 1463743432b..73faab8578e 100755
--- a/Master/texmf-dist/scripts/ctan-o-mat/ctan-o-mat.pl
+++ b/Master/texmf-dist/scripts/ctan-o-mat/ctan-o-mat.pl
@@ -18,7 +18,7 @@
=head1 NAME
-ctan-o-mat - Upload or validate a package for CTAN
+ctan-o-mat - Validate and upload a package for CTAN
=head1 SYNOPSIS
@@ -26,10 +26,11 @@ ctan-o-mat [options] [<package configuration>]
=head1 DESCRIPTION
-This program can be used to automate the upload of a package to CTAN
-(https://www.ctan.org). The description of the package is contained in
-a configuration file. Thus it can be updated easily without the need
-to fill a Web form with the same old information.
+This program can be used to automate the upload of a package to the
+Comprehensive TeX Archive Network (https://www.ctan.org). The description
+of the package is taken from a configuration file. Thus it can be updated
+easily without the need to fill a Web form with the same old information
+again and again.
The provided information is validated in any case. If the validation
succeeds and not only the validation is requested then the provided
@@ -52,10 +53,11 @@ The default configuration is read from a file with the same name as
the current directory an the extension .pkg. This file name can be
overwritten on the command line.
-The configuration depends on the features supported by the CTAN server.
+The configuration depends on the features currently supported by the
+CTAN server.
Since these features can change over time the configuration is not
-hard-coded in B<ctan-o-mat>. You can request a template of the
-configuration via the command line parameter C<-init>.
+hard-coded in B<ctan-o-mat>. You can request an empty template of the
+configuration via the command line parameter C<--init>.
=head1 OPTIONS
@@ -68,20 +70,19 @@ configuration via the command line parameter C<-init>.
Print this short summary about the usage and exit the program.
-=item --validate
+=item -i
-=item -n
+=item --init
-=item --noaction
+Create an empty template for a configuration.
-Do not perform the final upload. The package is validated and the
-resulting messages are printed.
+=item --config <package configuration>
-=item -i
+=item --pkg <package configuration>
-=item --init
+=item --package <package configuration>
-Create an empty template for a configuration.
+Set the package configuration file.
=item -s
@@ -102,15 +103,38 @@ Print the version number of this program and exit.
=item --validate
-Print some additional debugging information.
+=item -n
+
+=item --noaction
+
+Do not perform the final upload. The package is validated and the
+resulting messages are printed.
=item <package>
This parameter is the name of a package configuration
(see section CONFIGURATION) contained in a file.
+If not set otherwise the package configuration defaults to the
+name of the current directory with C<.pkg> appended.
+
+=back
+
+
+=head1 ENVIRONMENT
+
+The following environment variables are recognized by B<ctan-o-mat>.
+
+=over 4
+
+=item CTAN_O_MAT_URL
+
+The value is the URL prefix for the CTAN server to be contacted. The default
+is C<https://ctan.org/submit>. The complete URL is constructed by appending
+C<validate>, C<upload>, or C<fields> to use the respective CTAN REST API.
=back
+
=head1 CONNECTING VIA PROXIES
If you need to connect to the Internet via a proxy then this can be achieved
@@ -143,23 +167,12 @@ use FileHandle;
use File::Basename;
use Cwd;
-use LWP::UserAgent;
-use LWP::Protocol::https;
-use HTTP::Request::Common;
-
-use constant VERSION => '1.0';
-
-use constant NEW_CONFIG => 0;
-use constant UPLOAD => 1;
-use constant VALIDATE => 2;
-use constant INCREMENT => 3;
-
-my $CTAN_URL = 'http://localhost:8080/submit/';
+use constant VERSION => '1.1';
#------------------------------------------------------------------------------
-# Function: usage
+# Function: usage
# Arguments: none
-# Returns: nothing
+# Returns: nothing
# Description: Print the POD to stderr and exit
#
sub usage {
@@ -170,151 +183,125 @@ sub usage {
}
#------------------------------------------------------------------------------
-# Variable: $verbose
+# Variable: $verbose
# Description: The verbosity indicator.
#
my $verbose = 0;
#------------------------------------------------------------------------------
-# Variable: $method
-# Description: The validation or submit indicator.
-#
-my $method = VALIDATE;
-
-#------------------------------------------------------------------------------
-# Variable: $debug
+# Variable: $debug
# Description: The debug indicator.
#
my $debug = 0;
#------------------------------------------------------------------------------
-# Variable: $config
-# Description: The name of the configuration file.
+# Variable: $submit
+# Description: The validation or submit indicator.
#
-my $config = undef;
+my $submit = undef;
#------------------------------------------------------------------------------
-# Variable: @fields
-# Description:
+# Variable: $cfg
+# Description: The name of the configuration file.
#
-my %fields = ();
+my $cfg = undef;
#------------------------------------------------------------------------------
-# Variable: @parameter
-# Description: The list of fields
+# Variable: $CTAN_URL
+# Description: The base URL for requesting information from the CTAN server.
#
-my @parameter = ();
+my $CTAN_URL = $ENV{'CTAN_O_MAT_URL'} || 'https://ctan.org';
+$CTAN_URL .= '/' if not $CTAN_URL =~ m/\/$/;
use Getopt::Long;
GetOptions(
- "config=s" => \$config,
- "pkg=s" => \$config,
- "package=s" => \$config,
- "debug" => \$debug,
- "h|help" => \&usage,
- "increment" => sub { $method = INCREMENT },
- "init" => sub { $method = NEW_CONFIG },
- "n|noaction" => sub { $method = VALIDATE; },
- "submit" => sub { $method = UPLOAD; },
- "v|verbose" => \$verbose,
- "version" => sub { print STDOUT VERSION,"\n"; exit(0); },
- "validate" => sub { $method = VALIDATE; },
+ "config=s" => \$cfg,
+ "pkg=s" => \$cfg,
+ "package=s" => \$cfg,
+ "debug" => \$debug,
+ "h|help" => \&usage,
+ "i|init:s" => sub { local $_ = pkg_name_or_fallback($_[1], '');
+ (new CTAN::Pkg())
+ ->add(pkg => $_)
+ ->write(new CTAN::Upload::Fields());
+ exit(0);
+ },
+ "n|noaction" => sub { $submit = undef; },
+ "submit|upload" => sub { $submit = 1; },
+ "v|verbose" => \$verbose,
+ "validate" => sub { $submit = undef; },
+ "version" => sub { print STDOUT VERSION, "\n"; exit(0); },
);
-my $UPLOAD_URL = $CTAN_URL . 'upload';
-my $VALIDATE_URL = $CTAN_URL . 'validate';
-my $FIELDS_URL = $CTAN_URL . 'fields';
-
-$config = $ARGV[0] if defined $ARGV[0];
-if ( not defined $config ) {
- $config = cwd();
- $config =~ s|.*[/\\]||;
- $config = $config . '.pkg';
-}
-
-fields();
+(new CTAN::Pkg())
+ ->read(pkg_name_or_fallback($ARGV[0] || $cfg, '.pkg'))
+ ->upload($submit);
-if ( $method == NEW_CONFIG ) {
- new_config();
-} elsif ( $method == INCREMENT ) {
- increment_config();
-} else {
- upload( read_config() );
-}
#------------------------------------------------------------------------------
-# Function: upload
-# Arguments: none
-# Description:
+# Function: pkg_name_or_fallback
+# Arguments: $value the value
+# $ext the extension to append
+# Description: Construct a fallback from the current directory if $value is
+# not defined.
#
-sub upload {
- my $f = shift;
+sub pkg_name_or_fallback {
+ my ($value, $ext) = @_;
+ if ( not defined $value or $value eq '') {
+ $value = cwd();
+ $value =~ s|.*[/\\]||;
+ $value = $value . $ext;
+ }
+ return $value;
+}
- print STDERR "Uploading to CTAN..." if $verbose;
- my $service_url = $UPLOAD_URL;
- $service_url = $VALIDATE_URL if $method == VALIDATE;
- my $ua = LWP::UserAgent->new();
- my $request = POST $service_url,
- Content_Type => 'multipart/form-data',
- Content => $f;
- print STDERR "done\n" if $verbose;
- my $response = $ua->request($request);
+###############################################################################
+package CTAN::Upload::Fields;
- die format_errors( $response->decoded_content, $response->status_line ),
- "\n"
- if not $response->is_success;
+use LWP::UserAgent;
+use LWP::Protocol::https;
+use HTTP::Request::Common;
- if ( $method == VALIDATE and $response->decoded_content eq '[]' ) {
- print "ok\n";
- }
- else {
- print format_errors( $response->decoded_content, 'ok' ), "\n"
- }
-}
+#------------------------------------------------------------------------------
+# Variable: @parameter
+# Description: The list of fields.
+#
+my @parameter = ();
#------------------------------------------------------------------------------
-# Function: format_errors
-# Arguments:
-# $json the JSON list with the messages
-# $fallback the fallback message if the first parameter is empty
-# Description:
+# Constructor: new
+# Description: This is the constructor
#
-sub format_errors {
- local $_ = shift;
- if ( $_ eq '' ) {
- return shift;
- }
- s/^\[*\"//g;
- s/\]$//g;
- my @a = map {
- s/^ERROR\",\"/*** ERROR: /g;
- s/^WARNING\",\"/+++ WARNING: /g;
- s/^INFO\",\"/--- INFO: /g;
- s/\",\"/ /g;
- s/\"\]$//g;
- $_
- } split /\"\],\[\"/;
- return join( "\n", @a );
+sub new
+{ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $this = {};
+ bless $this,$class;
+ return $this->load();
}
#------------------------------------------------------------------------------
-# Function: fields
+# Method: load
# Arguments: none
-# Description:
+# Description: Retrieve a list of currently supported fields from the
+# CTAN server.
#
-sub fields {
- print STDERR "Retrieving fields from CTAN..." if $verbose;
- print STDERR $FIELDS_URL if $debug;
+sub load {
+ my $this = shift;
+ my $url = $CTAN_URL . 'submit/fields';
+
+ print STDERR "Retrieving fields from CTAN..." if $::verbose;
+ print STDERR $url,"\n" if $debug;
my $response;
eval {
my $ua = LWP::UserAgent->new();
- my $request = GET $FIELDS_URL;
- print STDERR "done\n" if $verbose;
+ my $request = GET $url;
+ print STDERR "done\n" if $::verbose;
$response = $ua->request($request);
};
- die format_errors( $response->decoded_content, $response->status_line ),
- "\n"
+ die CTAN::ErrorHandler::format( $response->decoded_content,
+ $response->status_line ), "\n"
if not $response->is_success;
local $_ = $response->decoded_content;
@@ -329,21 +316,88 @@ sub fields {
$a{$1} = $2;
$a{$1} =~ s/(^"|"$)//g;
}
- $fields{$f} = \%a;
- push @parameter, $f;
+ $this->{$f} = \%a;
+ push @CTAN::Upload::Fields::parameter, $f;
}
+ return $this;
}
+
+###############################################################################
+package CTAN::ErrorHandler;
+
#------------------------------------------------------------------------------
-# Function: read_config
+# Method: format
# Arguments:
+# $json the JSON list with the messages
+# $fallback the fallback message if the first parameter is empty
+# Description:
+#
+sub format{
+ local $_ = shift;
+ if ( $_ eq '' ) {
+ return shift;
+ }
+ if (m/^(<!DOCTYPE html>|<html)/i) {
+ return "Unexpected HTML response found under $CTAN_URL";
+ }
+
+ my $json = (new JSON::Parser())->parse($_);
+ return join("\n", map { join(': ', @$_ )} @$json);
+}
+
+
+###############################################################################
+package CTAN::Pkg;
+
+use LWP::UserAgent;
+use LWP::Protocol::https;
+use HTTP::Request::Common;
+
+#------------------------------------------------------------------------------
+# Constructor: new
+# Description: This is the constructor
+#
+sub new
+{ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $this = [];
+ return bless $this,$class;
+}
+
+#------------------------------------------------------------------------------
+# Method: add
+# Arguments: arbitrary many key/value pairs
+# Description:
+# This function adds a key/value pair to the object.
+#
+sub add {
+ my $this = shift;
+ my ($key, $val);
+ $key = shift;
+ $val = shift;
+ while (defined $key and defined $val) {
+ push @$this, $key => $val;
+ $key = shift;
+ $val = shift;
+ }
+ return $this;
+}
+
+#------------------------------------------------------------------------------
+# Method: read
+# Arguments: $file the file name to be read
# Description:
+# This function parses a configuration file in (La)TeX form and returns
+# it as hash-like list.
#
-sub read_config {
- my %cfg = ();
- my $fd = new FileHandle($config)
- || die "*** Configuration file `$config' could not be read.\n";
- my $slurp = undef;
+sub read {
+ my ($this, $file) = @_;
+ die "*** Configuration file missing.\n" if not defined $file;
+
+ my $fields = new CTAN::Upload::Fields();
+ my $fd = new FileHandle($file)
+ || die "*** Configuration file `$file' could not be read.\n";
local $_;
while (<$fd>) {
@@ -351,8 +405,9 @@ sub read_config {
s/([^\\])%.*/$1/;
while (m/\\([a-z]+)/i) {
$_ = $';
- if ( $1 eq 'begin' ) {
- die "$config: missing {environment} instead of $_\n"
+ my $keyword = $1;
+ if ( $keyword eq 'begin' ) {
+ die "$file:$.: missing {environment} instead of $_\n"
if not m/^[ \t]*\{([a-z]*)\}/i;
my $tag = $1;
my $val = '';
@@ -360,81 +415,86 @@ sub read_config {
while ( not m/\\end\{$tag\}/ ) {
$val .= $_;
$_ = <$fd>;
- die "$config: unexpected end of file while searching end of $tag\n"
+ die "$file:$.: "
+ . "unexpected end of file while searching end of $tag\n"
if not defined $_;
}
+ m/\\end\{$tag\}/;
+ $_ = $';
$val .= $`;
$val =~ s/^[ \t\n\r]*//m;
$val =~ s/[ \t\n\r]*$//m;
- $cfg{$tag} = $val;
- $_ = $';
+ push @$this, $tag => $val;
}
- elsif ( $1 eq 'endinput' ) {
+ elsif ( $keyword eq 'endinput' ) {
last;
}
- elsif ( defined $fields{$1} ) {
- my $key = $1;
- die "$config: missing {environment} instead of $_\n"
+ elsif ( defined $fields->{$keyword} ) {
+ die "$file:$.: missing {environment} instead of $_\n"
if not m/^[ \t]*\{([^{}]*)\}/i;
- if ( $key eq 'file' ) {
- $cfg{$key} = [$1];
- }
- else { $cfg{$key} = $1; }
+ if ( $keyword eq 'file' ) { push @$this, $keyword => [$1];
+ } else { push @$this, $keyword => $1; }
$_ = $';
}
else {
- die "$config: undefined keyword $&\n";
+ die "$file:$.: undefined keyword $keyword\n";
}
s/^[ \t]*%.*//;
}
}
$fd->close();
- return \%cfg;
+ return $this;
}
#------------------------------------------------------------------------------
-# Function: increment_config
-# Arguments: none
-# Description:
+# Method: upload
+# Arguments: ...
+# Description: Connect to the CTAN server to upload or validate the package.
#
-sub increment_config {
-
- my $modified = undef;
- my $fd = new FileHandle($config)
- || die "*** Configuration file `$config' could not be read.\n";
- local $_;
- my $content = '';
-
- while (<$fd>) {
- if (m/^[ \t]*%/) {
- $content .= $_;
- next;
- }
- if (m/\\version{([^}]*[^}0-9]*)([0-9]+)}/) {
- $content .= $` . "\\version{$1" . ($2 + 1) . "}" . $';
- $modified = 1;
- next;
- } else {
- $content .= $_;
- }
+sub upload {
+ my $this = shift;
+ my $submit = shift;
+
+ print STDERR "Uploading to CTAN..." if $verbose;
+ my $service_url;
+ if ($submit) {
+ $service_url = $CTAN_URL . 'submit/upload';
+ } else {
+ $service_url = $CTAN_URL . 'submit/validate';
}
- $fd->close();
-
- if ($modified) {
- rename $config, $config.'.bak';
- $fd = new FileHandle($config,'w');
- print $fd $content;
- $fd->close();
+ my $ua = LWP::UserAgent->new();
+ my $request = POST ($service_url,
+ 'Content_Type' => 'multipart/form-data',
+ 'Content' => $this);
+
+ print STDERR "done\n" if $verbose;
+ my $response = $ua->request($request);
+
+ die CTAN::ErrorHandler::format($response->decoded_content,
+ $response->status_line),
+ "\n"
+ if not $response->is_success;
+
+ if ( not $submit and $response->decoded_content eq '[]' ) {
+ print "ok\n";
+ }
+ else {
+ print CTAN::ErrorHandler::format( $response->decoded_content, 'ok' ),
+ "\n";
}
+ return $this;
}
#------------------------------------------------------------------------------
-# Function: new_config
+# Method: write
# Arguments: none
-# Description:
+# Description: Write a new configuration to stdout.
#
-sub new_config {
+sub write {
+ my $this = shift;
+ my %this = @$this;
+ my $fields = shift;
print <<__EOF__;
% This is a description file for ctan-o-mat.
@@ -452,41 +512,147 @@ sub new_config {
% named type.
__EOF__
local $_;
- foreach ( @parameter ) {
+ foreach (@CTAN::Upload::Fields::parameter) {
print <<__EOF__;
% -------------------------------------------------------------------------
-% This field contains the $fields{$_}->{'text'}.
+% This field contains the $fields->{$_}->{'text'}.
__EOF__
- if ( defined $fields{$_}->{'nullable'} ) {
+ if ( defined $fields->{$_}->{'nullable'} ) {
print "% The value is optional.\n";
}
- if ( defined $fields{$_}->{'url'} ) {
+ if ( defined $fields->{$_}->{'url'} ) {
print "% The value is a URL.\n";
}
- if ( defined $fields{$_}->{'email'} ) {
+ if ( defined $fields->{$_}->{'email'} ) {
print "% The value is an email address.\n";
}
- if ( defined $fields{$_}->{'file'} ) {
+ if ( defined $fields->{$_}->{'file'} ) {
print
"% The value is the file name of the archive to be uploaded.\n";
print "% It may have a relative or absolute directory.\n";
}
- if ( defined $fields{$_}->{'maxsize'} ) {
- print "% The value is restricted to $fields{$_}->{'maxsize'} characters.\n";
+ if ( defined $fields->{$_}->{'maxsize'} ) {
+ print
+"% The value is restricted to $fields->{$_}->{'maxsize'} characters.\n";
}
- if ( defined $fields{$_}->{'list'} ) {
+ if ( defined $fields->{$_}->{'list'} ) {
print "% Multiple values are allowed.\n\\$_\{}\n";
}
- elsif ( defined $fields{$_}->{'maxsize'}
- and $fields{$_}->{'maxsize'} ne 'null'
- and $fields{$_}->{'maxsize'} < 256 )
- {
- print "\\$_\{}\n";
+ elsif ( defined $fields->{$_}->{'maxsize'}
+ and $fields->{$_}->{'maxsize'} ne 'null'
+ and $fields->{$_}->{'maxsize'} < 256 )
+ { my $v = $this{$_};
+ $v = '' if not defined $v;
+ print "\\$_\{$v\}\n";
}
else {
- print "\\begin{$_}\\end{$_}\n";
+ my $v = $this{$_};
+ if (defined $v) {
+ $v = "\n " + $v + "\n";
+ } else {
+ $v = '';
+ }
+
+ print "\\begin{$_}$v\\end{$_}\n";
+ }
+ }
+}
+
+###############################################################################
+
+package JSON::Parser;
+#------------------------------------------------------------------------------
+# Constructor: new
+# Description: This is the constructor
+#
+sub new
+{ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $this = {};
+ return bless $this,$class;
+}
+
+#------------------------------------------------------------------------------
+# Method: parse
+# Arguments:
+# $json the JSON list with the messages
+# Description: Parse the input string for a JSON object and retrun the Perl
+# representation of it.
+#
+sub parse {
+ my ($this, $json) = @_;
+ my ( $result, $remainder ) = $this->scan($json);
+ chomp $remainder;
+ if ($remainder ne '' ) {
+ die "Unprocessed JSON: $remainder\n";
+ }
+ return $result;
+}
+
+#------------------------------------------------------------------------------
+# Method: scan
+# Arguments:
+# $json the JSON list with the messages
+# Description: Scan the input string for the next token
+#
+sub scan {
+ my ($this, $json) = @_;
+ local $_;
+ $json =~ s/^\s+//;
+ if ($json =~ m/^\[\s*/) {
+ my @a = ();
+ $json = $';
+ while ( not $json =~ m/^\]/ ) {
+ my ($el, $remainder) = $this->scan($json);
+ push @a, $el;
+ $json = $remainder;
+ if ($json =~ m/^\s*,/) {
+ $json = $';
+ }
+ }
+ $json = substr($json, 1);
+ return ( \@a, $json );
+ }
+ elsif ($json =~ m/^"/) {
+ $json = $';
+ my $s = '';
+ while ($json =~ m/(\\.|")/) {
+ $s .= $`;
+ $json = $';
+ if ( $& eq '"' ) {
+ return ($s, $json);
+ }
+ if ( $& eq '\\n' ) {
+ $s .= "\n";
+ }
+ elsif ( $& eq '\\"' ) {
+ $s .= '"';
+ }
+ elsif ( $& eq '\\t' ) {
+ $s .= "\t";
+ }
+ elsif ( $& eq '\\\\' ) {
+ $s .= "\\";
+ }
+ elsif ( $& eq '\\r' ) {
+ $s .= "\r";
+ }
+ elsif ( $& eq '\\b' ) {
+ $s .= "\b";
+ }
+ else {
+ $s .= "\\";
+ }
}
+ die "missing end of string\n";
}
+ elsif ($json =~ m/^([0-9]+|[a-z]+)/i) {
+ $json = $';
+ $_ = $&;
+ return ( $_, $json );
+ }
+
+ die "Parse error at: $json\n";
}
#------------------------------------------------------------------------------