texlive[45907] trunk: ctan-o-mat (25nov17)
commits+karl at tug.org
commits+karl at tug.org
Sat Nov 25 21:59:20 CET 2017
Revision: 45907
http://tug.org/svn/texlive?view=revision&revision=45907
Author: karl
Date: 2017-11-25 21:59:19 +0100 (Sat, 25 Nov 2017)
Log Message:
-----------
ctan-o-mat (25nov17)
Modified Paths:
--------------
trunk/Build/source/texk/texlive/linked_scripts/ctan-o-mat/ctan-o-mat.pl
trunk/Master/texmf-dist/doc/man/man1/ctan-o-mat.1
trunk/Master/texmf-dist/doc/man/man1/ctan-o-mat.man1.pdf
trunk/Master/texmf-dist/doc/support/ctan-o-mat/README.md
trunk/Master/texmf-dist/doc/support/ctan-o-mat/ctan-o-mat.pkg
trunk/Master/texmf-dist/doc/support/ctan-o-mat/makefile
trunk/Master/texmf-dist/scripts/ctan-o-mat/ctan-o-mat.pl
trunk/Master/texmf-dist/source/support/ctan-o-mat/ctan-o-mat.bat
Modified: trunk/Build/source/texk/texlive/linked_scripts/ctan-o-mat/ctan-o-mat.pl
===================================================================
--- trunk/Build/source/texk/texlive/linked_scripts/ctan-o-mat/ctan-o-mat.pl 2017-11-25 20:59:01 UTC (rev 45906)
+++ trunk/Build/source/texk/texlive/linked_scripts/ctan-o-mat/ctan-o-mat.pl 2017-11-25 20:59:19 UTC (rev 45907)
@@ -76,6 +76,13 @@
Create an empty template for a configuration.
+=item --list licenses
+
+List the known licenses of CTAN to the standard output stream.
+Each license is represented as one line. The line contains the fields
+key, name, free indicator. Those fields are separated by tab characters.
+Afterwards the program terminates without processing any further arguments.
+
=item --config <package configuration>
=item --pkg <package configuration>
@@ -167,7 +174,7 @@
use File::Basename;
use Cwd;
-use constant VERSION => '1.1';
+use constant VERSION => '1.2';
#------------------------------------------------------------------------------
# Function: usage
@@ -215,29 +222,40 @@
use Getopt::Long;
GetOptions(
- "config=s" => \$cfg,
+ "config=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);
+ },
+ "list=s" => sub {
+ if ( $_[1] eq 'licenses' ) {
+ new CTAN::Licenses()->print();
+ }
+ else {
+ print STDERR "*** Unknown entity $_[1]\n";
+ }
+ exit(0);
+ },
+ "n|noaction" => sub { $submit = undef; },
"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; },
+ "validate" => sub { $submit = undef; },
"v|verbose" => \$verbose,
- "validate" => sub { $submit = undef; },
- "version" => sub { print STDOUT VERSION, "\n"; exit(0); },
+ "version" => sub {
+ print STDOUT VERSION, "\n";
+ exit(0);
+ },
);
-(new CTAN::Pkg())
- ->read(pkg_name_or_fallback($ARGV[0] || $cfg, '.pkg'))
- ->upload($submit);
+new CTAN::Pkg()
+ ->read( pkg_name_or_fallback( $ARGV[0] || $cfg, '.pkg' ) )
+ ->upload($submit);
-
#------------------------------------------------------------------------------
# Function: pkg_name_or_fallback
# Arguments: $value the value
@@ -246,8 +264,8 @@
# not defined.
#
sub pkg_name_or_fallback {
- my ($value, $ext) = @_;
- if ( not defined $value or $value eq '') {
+ my ( $value, $ext ) = @_;
+ if ( not defined $value or $value eq '' ) {
$value = cwd();
$value =~ s|.*[/\\]||;
$value = $value . $ext;
@@ -256,6 +274,120 @@
}
###############################################################################
+
+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 ( m/^\[\s*/ ) {
+ my @a = ();
+ $_ = $';
+ while ( not m/^\]/ ) {
+ my ( $el, $remainder ) = $this->scan($_);
+ push @a, $el;
+ $_ = $remainder;
+ s/^\s*,\s*//;
+ }
+ $_ = substr( $_, 1 );
+ return ( \@a, $_ );
+ }
+ elsif ( m/^\{\s*/ ) {
+ my %a = ();
+ $_ = $';
+ while ( not m/^\}/ ) {
+ my ( $key, $remainder ) = $this->scan($_);
+ $_ = $remainder;
+ s/^\s*:\s*//;
+ my ( $val, $remainder2 ) = $this->scan($_);
+ $_ = $remainder2;
+ $a{$key} = $val;
+ s/^\s*,\s*//;
+ }
+ $_ = substr( $_, 1 );
+ return ( \%a, $_ );
+ }
+ elsif ( $_ =~ m/^"/ ) {
+ $_ = $';
+ my $s = '';
+ while ( m/(\\.|")/ ) {
+ $s .= $`;
+ $_ = $';
+ if ( $& eq '"' ) {
+ return ( $s, $_ );
+ }
+ 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 ( m/^([0-9]+|[a-z]+)/i ) {
+ $_ = $';
+ $_ = $&;
+ return ( $_, $_ );
+ }
+
+ die "*** Parse error at: $_\n";
+}
+
+###############################################################################
package CTAN::Upload::Fields;
use LWP::UserAgent;
@@ -266,32 +398,32 @@
# Variable: @parameter
# Description: The list of fields.
#
-my @parameter = ();
+my @parameter = (); # FIXME
#------------------------------------------------------------------------------
# Constructor: new
# Description: This is the constructor
#
-sub new
-{ my $proto = shift;
- my $class = ref($proto) || $proto;
- my $this = {};
- bless $this,$class;
- return $this->load();
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $this = {};
+ bless $this, $class;
+ return $this->_load();
}
#------------------------------------------------------------------------------
-# Method: load
+# Method: _load
# Arguments: none
# Description: Retrieve a list of currently supported fields from the
# CTAN server.
#
-sub load {
+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 $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();
@@ -300,8 +432,10 @@
$response = $ua->request($request);
};
- die CTAN::ErrorHandler::format( $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;
@@ -322,7 +456,88 @@
return $this;
}
+###############################################################################
+package CTAN::Licenses;
+use LWP::UserAgent;
+use LWP::Protocol::https;
+use HTTP::Request::Common;
+
+use Data::Dumper;
+
+#------------------------------------------------------------------------------
+# Constructor: new
+# Description: This is the constructor
+#
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $this = [];
+ bless $this, $class;
+ return $this->_load();
+}
+
+#------------------------------------------------------------------------------
+# Method: _load
+# Arguments: none
+# Description: Retrieve a list of currently supported licenses from the
+# CTAN server.
+#
+sub _load {
+ my $this = shift;
+ my $url = $CTAN_URL . 'json/1.3/licenses';
+
+ print STDERR "--- Retrieving licenses from CTAN..." if $verbose;
+ print STDERR $url, "\t" if $debug;
+ my $response;
+ eval {
+ my $ua = LWP::UserAgent->new();
+ my $request = GET $url;
+ print STDERR "done\n" if $verbose;
+ $response = $ua->request($request);
+ };
+
+ die CTAN::ErrorHandler::format(
+ $response->decoded_content, $response->status_line
+ ),
+ "\n"
+ if not $@ and not $response->is_success;
+
+ print STDERR "done\n" if $verbose;
+ local $_ = $response->decoded_content;
+
+ eval {
+ $this->[0] = new JSON::Parser()->parse($_);
+ };
+ if ($@) {
+ s/^[0-9]+ */*** /;
+ die $_;
+ }
+
+ return $this;
+}
+
+#------------------------------------------------------------------------------
+# Method: print
+# Arguments: none
+# Description: Print the licenses to stdout.
+#
+sub print {
+ my $this = shift;
+ local $_ = $this->[0];
+ my @a = @$_;
+
+ foreach (@a) {
+ print $_->{key}, "\t", $_->{name}, "\t";
+ if ( $_->{free} eq 'true' ) {
+ print "free\n";
+ }
+ else {
+ print "non-free\n";
+ }
+ }
+}
+
###############################################################################
package CTAN::ErrorHandler;
@@ -331,9 +546,9 @@
# Arguments:
# $json the JSON list with the messages
# $fallback the fallback message if the first parameter is empty
-# Description:
+# Description: format the JSON error message
#
-sub format{
+sub format {
local $_ = shift;
if ( $_ eq '' ) {
return shift;
@@ -341,12 +556,18 @@
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);
+
+ my $json;
+ eval {
+ $json = new JSON::Parser()->parse($_);
+ };
+ if ($@) {
+ s/^[0-9]+ */*** /;
+ die $_;
+ }
+ return join( "\n", map { join( ': ', @$_ ) } @$json );
}
-
###############################################################################
package CTAN::Pkg;
@@ -358,11 +579,11 @@
# Constructor: new
# Description: This is the constructor
#
-sub new
-{ my $proto = shift;
- my $class = ref($proto) || $proto;
- my $this = [];
- return bless $this,$class;
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $this = [];
+ return bless $this, $class;
}
#------------------------------------------------------------------------------
@@ -373,11 +594,14 @@
#
sub add {
my $this = shift;
- my ($key, $val);
+ my ( $key, $val );
$key = shift;
$val = shift;
- while (defined $key and defined $val) {
- push @$this, $key => $val;
+ while ( defined $key and defined $val ) {
+ if ( $key eq 'file' ) {
+ push @$this, $key => [$val];
+ }
+ else { push @$this, $key => $val; }
$key = shift;
$val = shift;
}
@@ -392,11 +616,11 @@
# it as hash-like list.
#
sub read {
- my ($this, $file) = @_;
+ my ( $this, $file ) = @_;
die "*** Configuration file missing.\n" if not defined $file;
-
+
my $fields = new CTAN::Upload::Fields();
- my $fd = new FileHandle($file)
+ my $fd = new FileHandle($file)
|| die "*** Configuration file `$file' could not be read.\n";
local $_;
@@ -409,22 +633,22 @@
if ( $keyword eq 'begin' ) {
die "$file:$.: missing {environment} instead of $_\n"
if not m/^[ \t]*\{([a-z]*)\}/i;
- my $tag = $1;
+ $keyword = $1;
my $val = '';
$_ = $';
- while ( not m/\\end\{$tag\}/ ) {
+ while ( not m/\\end\{$keyword\}/ ) {
$val .= $_;
$_ = <$fd>;
die "$file:$.: "
- . "unexpected end of file while searching end of $tag\n"
+ . "unexpected end of file while searching end of $keyword\n"
if not defined $_;
}
- m/\\end\{$tag\}/;
+ m/\\end\{$keyword\}/;
$_ = $';
$val .= $`;
$val =~ s/^[ \t\n\r]*//m;
$val =~ s/[ \t\n\r]*$//m;
- push @$this, $tag => $val;
+ $this->add( $keyword => $val );
}
elsif ( $keyword eq 'endinput' ) {
last;
@@ -432,10 +656,8 @@
elsif ( defined $fields->{$keyword} ) {
die "$file:$.: missing {environment} instead of $_\n"
if not m/^[ \t]*\{([^{}]*)\}/i;
-
- if ( $keyword eq 'file' ) { push @$this, $keyword => [$1];
- } else { push @$this, $keyword => $1; }
$_ = $';
+ $this->add( $keyword => $1 );
}
else {
die "$file:$.: undefined keyword $keyword\n";
@@ -449,39 +671,45 @@
#------------------------------------------------------------------------------
# Method: upload
-# Arguments: ...
+# Arguments: Upload a file and the parameters
# Description: Connect to the CTAN server to upload or validate the package.
#
sub upload {
- my $this = shift;
+ my $this = shift;
my $submit = shift;
- print STDERR "Uploading to CTAN..." if $verbose;
my $service_url;
if ($submit) {
+ print STDERR "--- Sending to CTAN for submission..." if $verbose;
$service_url = $CTAN_URL . 'submit/upload';
- } else {
+ }
+ else {
+ print STDERR "--- Uploading to CTAN for validation..." if $verbose;
$service_url = $CTAN_URL . 'submit/validate';
}
my $ua = LWP::UserAgent->new();
- my $request = POST ($service_url,
- 'Content_Type' => 'multipart/form-data',
- 'Content' => $this);
-
+ my $request = POST(
+ $service_url,
+ 'Content_Type' => 'multipart/form-data',
+ 'Content' => $this
+ );
+ my $response = $ua->request($request);
print STDERR "done\n" if $verbose;
- my $response = $ua->request($request);
- die CTAN::ErrorHandler::format($response->decoded_content,
- $response->status_line),
- "\n"
+ 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";
+ print STDERR "--- The validation has succeeded.\n",
+ "--- You can now submit your package to CTAN for publication.\n"
+ if $verbose;
}
else {
print CTAN::ErrorHandler::format( $response->decoded_content, 'ok' ),
- "\n";
+ "\n";
}
return $this;
}
@@ -492,8 +720,8 @@
# Description: Write a new configuration to stdout.
#
sub write {
- my $this = shift;
- my %this = @$this;
+ my $this = shift;
+ my %this = @$this;
my $fields = shift;
print <<__EOF__;
@@ -532,8 +760,8 @@
print "% It may have a relative or absolute directory.\n";
}
if ( defined $fields->{$_}->{'maxsize'} ) {
- print
-"% The value is restricted to $fields->{$_}->{'maxsize'} characters.\n";
+ print "% The value is restricted to ", $fields->{$_}->{'maxsize'},
+ " characters.\n";
}
if ( defined $fields->{$_}->{'list'} ) {
print "% Multiple values are allowed.\n\\$_\{}\n";
@@ -541,121 +769,33 @@
elsif ( defined $fields->{$_}->{'maxsize'}
and $fields->{$_}->{'maxsize'} ne 'null'
and $fields->{$_}->{'maxsize'} < 256 )
- { my $v = $this{$_};
- $v = '' if not defined $v;
+ {
+ my $v = $this{$_};
+ $v = '' if not defined $v;
print "\\$_\{$v\}\n";
}
+ elsif ( defined $fields->{$_}->{'file'}
+ and $fields->{$_}->{'file'} eq 'true' )
+ {
+ my $v = $this{$_};
+ $v = '' if not defined $v;
+ print "\\$_\{$v\}\n";
+ }
else {
my $v = $this{$_};
- if (defined $v) {
+ if ( defined $v ) {
$v = "\n " + $v + "\n";
- } else {
+ }
+ 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";
-}
-
-#------------------------------------------------------------------------------
# Local Variables:
# mode: perl
# End:
Modified: trunk/Master/texmf-dist/doc/man/man1/ctan-o-mat.1
===================================================================
--- trunk/Master/texmf-dist/doc/man/man1/ctan-o-mat.1 2017-11-25 20:59:01 UTC (rev 45906)
+++ trunk/Master/texmf-dist/doc/man/man1/ctan-o-mat.1 2017-11-25 20:59:19 UTC (rev 45907)
@@ -129,7 +129,7 @@
.\" ========================================================================
.\"
.IX Title "CTAN-O-MAT 1"
-.TH CTAN-O-MAT 1 "2017-11-16" "ctan-o-mat" "Gerd Neugebauer"
+.TH CTAN-O-MAT 1 "2017-11-23" "ctan-o-mat" "Gerd Neugebauer"
.\" For nroff, turn off justification. Always turn off hyphenation; it makes
.\" way too many mistakes in technical documents.
.if n .ad l
@@ -187,6 +187,12 @@
.IX Item "--init"
.PD
Create an empty template for a configuration.
+.IP "\-\-list licenses" 4
+.IX Item "--list licenses"
+List the known licenses of \s-1CTAN\s0 to the standard output stream.
+Each license is represented as one line. The line contains the fields
+key, name, free indicator. Those fields are separated by tab characters.
+Afterwards the program terminates without processing any further arguments.
.IP "\-\-config <package configuration>" 4
.IX Item "--config <package configuration>"
.PD 0
Modified: trunk/Master/texmf-dist/doc/man/man1/ctan-o-mat.man1.pdf
===================================================================
(Binary files differ)
Modified: trunk/Master/texmf-dist/doc/support/ctan-o-mat/README.md
===================================================================
--- trunk/Master/texmf-dist/doc/support/ctan-o-mat/README.md 2017-11-25 20:59:01 UTC (rev 45906)
+++ trunk/Master/texmf-dist/doc/support/ctan-o-mat/README.md 2017-11-25 20:59:19 UTC (rev 45907)
@@ -55,6 +55,15 @@
Create an empty template for a configuration.
</dd>
+ <dt><code>--list licenses</code></dt>
+ <dd>
+ List the known licenses of CTAN to the standard output stream.
+ Each license is represented as one line. The line contains the
+ fields key, name, free indicator. Those fields are separated by
+ tab characters. Afterwards the program terminates without processing
+ any further arguments.
+ </dd>
+
<dt><code>--submit</code></dt>
<dd>
Upload the submission, validate it and officially submit it to
Modified: trunk/Master/texmf-dist/doc/support/ctan-o-mat/ctan-o-mat.pkg
===================================================================
--- trunk/Master/texmf-dist/doc/support/ctan-o-mat/ctan-o-mat.pkg 2017-11-25 20:59:01 UTC (rev 45906)
+++ trunk/Master/texmf-dist/doc/support/ctan-o-mat/ctan-o-mat.pkg 2017-11-25 20:59:19 UTC (rev 45907)
@@ -20,7 +20,7 @@
% This field contains the version of the package.
% The value is optional.
% The value is restricted to 32 characters.
-\version{1.1}
+\version{1.2}
% -------------------------------------------------------------------------
% This field contains the name of the author(s).
% The value is optional.
@@ -102,9 +102,11 @@
Changes:
-- Handling of directories with spaces improved.
-- Error messages improved.
-- Wrong version on CTAN fixed
+- Command line parameter `--list licenses' added to retrieve the
+ known keys for licenses.
+- Verbose message for validation improved.
+- --init creates macro for \file instead of an environment.
+- Now environments and macros are close to be identical.
\end{announcement}
% -------------------------------------------------------------------------
% This field contains the one-liner for the package.
@@ -138,8 +140,6 @@
% The value is optional.
% The value is restricted to 2048 characters.
\begin{note}
-Sorry, the wrong zip has made it to CTAN.
-This gives me the chance to publish a few minor problems too.
\end{note}
% -------------------------------------------------------------------------
% This field contains the archive file.
Modified: trunk/Master/texmf-dist/doc/support/ctan-o-mat/makefile
===================================================================
--- trunk/Master/texmf-dist/doc/support/ctan-o-mat/makefile 2017-11-25 20:59:01 UTC (rev 45906)
+++ trunk/Master/texmf-dist/doc/support/ctan-o-mat/makefile 2017-11-25 20:59:19 UTC (rev 45907)
@@ -30,7 +30,7 @@
#------------------------------------------------------------------------------
-all:
+all: validate
clean distclean:
$(RM) -f *~ *.out *.log *.aux ctan-o-mat.ltx
@@ -41,6 +41,12 @@
@$(LATEX) -interaction=batchmode ctan-o-mat.latex
@$(RM) ctan-o-mat.out ctan-o-mat.aux ctan-o-mat.log ctan-o-mat.latex
+val validate: ctan-o-mat.pdf ctan-o-mat.zip
+ @./ctan-o-mat
+
+submit upload: ctan-o-mat.pdf ctan-o-mat.zip
+ @./ctan-o-mat -submit
+
dist ctan-o-mat.zip: $(FILES)
$(RM) ctan-o-mat.zip
(cd ..; zip ctan-o-mat/ctan-o-mat.zip $(addprefix ctan-o-mat/,$(FILES)))
Modified: trunk/Master/texmf-dist/scripts/ctan-o-mat/ctan-o-mat.pl
===================================================================
--- trunk/Master/texmf-dist/scripts/ctan-o-mat/ctan-o-mat.pl 2017-11-25 20:59:01 UTC (rev 45906)
+++ trunk/Master/texmf-dist/scripts/ctan-o-mat/ctan-o-mat.pl 2017-11-25 20:59:19 UTC (rev 45907)
@@ -76,6 +76,13 @@
Create an empty template for a configuration.
+=item --list licenses
+
+List the known licenses of CTAN to the standard output stream.
+Each license is represented as one line. The line contains the fields
+key, name, free indicator. Those fields are separated by tab characters.
+Afterwards the program terminates without processing any further arguments.
+
=item --config <package configuration>
=item --pkg <package configuration>
@@ -167,7 +174,7 @@
use File::Basename;
use Cwd;
-use constant VERSION => '1.1';
+use constant VERSION => '1.2';
#------------------------------------------------------------------------------
# Function: usage
@@ -215,29 +222,40 @@
use Getopt::Long;
GetOptions(
- "config=s" => \$cfg,
+ "config=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);
+ },
+ "list=s" => sub {
+ if ( $_[1] eq 'licenses' ) {
+ new CTAN::Licenses()->print();
+ }
+ else {
+ print STDERR "*** Unknown entity $_[1]\n";
+ }
+ exit(0);
+ },
+ "n|noaction" => sub { $submit = undef; },
"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; },
+ "validate" => sub { $submit = undef; },
"v|verbose" => \$verbose,
- "validate" => sub { $submit = undef; },
- "version" => sub { print STDOUT VERSION, "\n"; exit(0); },
+ "version" => sub {
+ print STDOUT VERSION, "\n";
+ exit(0);
+ },
);
-(new CTAN::Pkg())
- ->read(pkg_name_or_fallback($ARGV[0] || $cfg, '.pkg'))
- ->upload($submit);
+new CTAN::Pkg()
+ ->read( pkg_name_or_fallback( $ARGV[0] || $cfg, '.pkg' ) )
+ ->upload($submit);
-
#------------------------------------------------------------------------------
# Function: pkg_name_or_fallback
# Arguments: $value the value
@@ -246,8 +264,8 @@
# not defined.
#
sub pkg_name_or_fallback {
- my ($value, $ext) = @_;
- if ( not defined $value or $value eq '') {
+ my ( $value, $ext ) = @_;
+ if ( not defined $value or $value eq '' ) {
$value = cwd();
$value =~ s|.*[/\\]||;
$value = $value . $ext;
@@ -256,6 +274,120 @@
}
###############################################################################
+
+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 ( m/^\[\s*/ ) {
+ my @a = ();
+ $_ = $';
+ while ( not m/^\]/ ) {
+ my ( $el, $remainder ) = $this->scan($_);
+ push @a, $el;
+ $_ = $remainder;
+ s/^\s*,\s*//;
+ }
+ $_ = substr( $_, 1 );
+ return ( \@a, $_ );
+ }
+ elsif ( m/^\{\s*/ ) {
+ my %a = ();
+ $_ = $';
+ while ( not m/^\}/ ) {
+ my ( $key, $remainder ) = $this->scan($_);
+ $_ = $remainder;
+ s/^\s*:\s*//;
+ my ( $val, $remainder2 ) = $this->scan($_);
+ $_ = $remainder2;
+ $a{$key} = $val;
+ s/^\s*,\s*//;
+ }
+ $_ = substr( $_, 1 );
+ return ( \%a, $_ );
+ }
+ elsif ( $_ =~ m/^"/ ) {
+ $_ = $';
+ my $s = '';
+ while ( m/(\\.|")/ ) {
+ $s .= $`;
+ $_ = $';
+ if ( $& eq '"' ) {
+ return ( $s, $_ );
+ }
+ 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 ( m/^([0-9]+|[a-z]+)/i ) {
+ $_ = $';
+ $_ = $&;
+ return ( $_, $_ );
+ }
+
+ die "*** Parse error at: $_\n";
+}
+
+###############################################################################
package CTAN::Upload::Fields;
use LWP::UserAgent;
@@ -266,32 +398,32 @@
# Variable: @parameter
# Description: The list of fields.
#
-my @parameter = ();
+my @parameter = (); # FIXME
#------------------------------------------------------------------------------
# Constructor: new
# Description: This is the constructor
#
-sub new
-{ my $proto = shift;
- my $class = ref($proto) || $proto;
- my $this = {};
- bless $this,$class;
- return $this->load();
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $this = {};
+ bless $this, $class;
+ return $this->_load();
}
#------------------------------------------------------------------------------
-# Method: load
+# Method: _load
# Arguments: none
# Description: Retrieve a list of currently supported fields from the
# CTAN server.
#
-sub load {
+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 $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();
@@ -300,8 +432,10 @@
$response = $ua->request($request);
};
- die CTAN::ErrorHandler::format( $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;
@@ -322,7 +456,88 @@
return $this;
}
+###############################################################################
+package CTAN::Licenses;
+use LWP::UserAgent;
+use LWP::Protocol::https;
+use HTTP::Request::Common;
+
+use Data::Dumper;
+
+#------------------------------------------------------------------------------
+# Constructor: new
+# Description: This is the constructor
+#
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $this = [];
+ bless $this, $class;
+ return $this->_load();
+}
+
+#------------------------------------------------------------------------------
+# Method: _load
+# Arguments: none
+# Description: Retrieve a list of currently supported licenses from the
+# CTAN server.
+#
+sub _load {
+ my $this = shift;
+ my $url = $CTAN_URL . 'json/1.3/licenses';
+
+ print STDERR "--- Retrieving licenses from CTAN..." if $verbose;
+ print STDERR $url, "\t" if $debug;
+ my $response;
+ eval {
+ my $ua = LWP::UserAgent->new();
+ my $request = GET $url;
+ print STDERR "done\n" if $verbose;
+ $response = $ua->request($request);
+ };
+
+ die CTAN::ErrorHandler::format(
+ $response->decoded_content, $response->status_line
+ ),
+ "\n"
+ if not $@ and not $response->is_success;
+
+ print STDERR "done\n" if $verbose;
+ local $_ = $response->decoded_content;
+
+ eval {
+ $this->[0] = new JSON::Parser()->parse($_);
+ };
+ if ($@) {
+ s/^[0-9]+ */*** /;
+ die $_;
+ }
+
+ return $this;
+}
+
+#------------------------------------------------------------------------------
+# Method: print
+# Arguments: none
+# Description: Print the licenses to stdout.
+#
+sub print {
+ my $this = shift;
+ local $_ = $this->[0];
+ my @a = @$_;
+
+ foreach (@a) {
+ print $_->{key}, "\t", $_->{name}, "\t";
+ if ( $_->{free} eq 'true' ) {
+ print "free\n";
+ }
+ else {
+ print "non-free\n";
+ }
+ }
+}
+
###############################################################################
package CTAN::ErrorHandler;
@@ -331,9 +546,9 @@
# Arguments:
# $json the JSON list with the messages
# $fallback the fallback message if the first parameter is empty
-# Description:
+# Description: format the JSON error message
#
-sub format{
+sub format {
local $_ = shift;
if ( $_ eq '' ) {
return shift;
@@ -341,12 +556,18 @@
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);
+
+ my $json;
+ eval {
+ $json = new JSON::Parser()->parse($_);
+ };
+ if ($@) {
+ s/^[0-9]+ */*** /;
+ die $_;
+ }
+ return join( "\n", map { join( ': ', @$_ ) } @$json );
}
-
###############################################################################
package CTAN::Pkg;
@@ -358,11 +579,11 @@
# Constructor: new
# Description: This is the constructor
#
-sub new
-{ my $proto = shift;
- my $class = ref($proto) || $proto;
- my $this = [];
- return bless $this,$class;
+sub new {
+ my $proto = shift;
+ my $class = ref($proto) || $proto;
+ my $this = [];
+ return bless $this, $class;
}
#------------------------------------------------------------------------------
@@ -373,11 +594,14 @@
#
sub add {
my $this = shift;
- my ($key, $val);
+ my ( $key, $val );
$key = shift;
$val = shift;
- while (defined $key and defined $val) {
- push @$this, $key => $val;
+ while ( defined $key and defined $val ) {
+ if ( $key eq 'file' ) {
+ push @$this, $key => [$val];
+ }
+ else { push @$this, $key => $val; }
$key = shift;
$val = shift;
}
@@ -392,11 +616,11 @@
# it as hash-like list.
#
sub read {
- my ($this, $file) = @_;
+ my ( $this, $file ) = @_;
die "*** Configuration file missing.\n" if not defined $file;
-
+
my $fields = new CTAN::Upload::Fields();
- my $fd = new FileHandle($file)
+ my $fd = new FileHandle($file)
|| die "*** Configuration file `$file' could not be read.\n";
local $_;
@@ -409,22 +633,22 @@
if ( $keyword eq 'begin' ) {
die "$file:$.: missing {environment} instead of $_\n"
if not m/^[ \t]*\{([a-z]*)\}/i;
- my $tag = $1;
+ $keyword = $1;
my $val = '';
$_ = $';
- while ( not m/\\end\{$tag\}/ ) {
+ while ( not m/\\end\{$keyword\}/ ) {
$val .= $_;
$_ = <$fd>;
die "$file:$.: "
- . "unexpected end of file while searching end of $tag\n"
+ . "unexpected end of file while searching end of $keyword\n"
if not defined $_;
}
- m/\\end\{$tag\}/;
+ m/\\end\{$keyword\}/;
$_ = $';
$val .= $`;
$val =~ s/^[ \t\n\r]*//m;
$val =~ s/[ \t\n\r]*$//m;
- push @$this, $tag => $val;
+ $this->add( $keyword => $val );
}
elsif ( $keyword eq 'endinput' ) {
last;
@@ -432,10 +656,8 @@
elsif ( defined $fields->{$keyword} ) {
die "$file:$.: missing {environment} instead of $_\n"
if not m/^[ \t]*\{([^{}]*)\}/i;
-
- if ( $keyword eq 'file' ) { push @$this, $keyword => [$1];
- } else { push @$this, $keyword => $1; }
$_ = $';
+ $this->add( $keyword => $1 );
}
else {
die "$file:$.: undefined keyword $keyword\n";
@@ -449,39 +671,45 @@
#------------------------------------------------------------------------------
# Method: upload
-# Arguments: ...
+# Arguments: Upload a file and the parameters
# Description: Connect to the CTAN server to upload or validate the package.
#
sub upload {
- my $this = shift;
+ my $this = shift;
my $submit = shift;
- print STDERR "Uploading to CTAN..." if $verbose;
my $service_url;
if ($submit) {
+ print STDERR "--- Sending to CTAN for submission..." if $verbose;
$service_url = $CTAN_URL . 'submit/upload';
- } else {
+ }
+ else {
+ print STDERR "--- Uploading to CTAN for validation..." if $verbose;
$service_url = $CTAN_URL . 'submit/validate';
}
my $ua = LWP::UserAgent->new();
- my $request = POST ($service_url,
- 'Content_Type' => 'multipart/form-data',
- 'Content' => $this);
-
+ my $request = POST(
+ $service_url,
+ 'Content_Type' => 'multipart/form-data',
+ 'Content' => $this
+ );
+ my $response = $ua->request($request);
print STDERR "done\n" if $verbose;
- my $response = $ua->request($request);
- die CTAN::ErrorHandler::format($response->decoded_content,
- $response->status_line),
- "\n"
+ 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";
+ print STDERR "--- The validation has succeeded.\n",
+ "--- You can now submit your package to CTAN for publication.\n"
+ if $verbose;
}
else {
print CTAN::ErrorHandler::format( $response->decoded_content, 'ok' ),
- "\n";
+ "\n";
}
return $this;
}
@@ -492,8 +720,8 @@
# Description: Write a new configuration to stdout.
#
sub write {
- my $this = shift;
- my %this = @$this;
+ my $this = shift;
+ my %this = @$this;
my $fields = shift;
print <<__EOF__;
@@ -532,8 +760,8 @@
print "% It may have a relative or absolute directory.\n";
}
if ( defined $fields->{$_}->{'maxsize'} ) {
- print
-"% The value is restricted to $fields->{$_}->{'maxsize'} characters.\n";
+ print "% The value is restricted to ", $fields->{$_}->{'maxsize'},
+ " characters.\n";
}
if ( defined $fields->{$_}->{'list'} ) {
print "% Multiple values are allowed.\n\\$_\{}\n";
@@ -541,121 +769,33 @@
elsif ( defined $fields->{$_}->{'maxsize'}
and $fields->{$_}->{'maxsize'} ne 'null'
and $fields->{$_}->{'maxsize'} < 256 )
- { my $v = $this{$_};
- $v = '' if not defined $v;
+ {
+ my $v = $this{$_};
+ $v = '' if not defined $v;
print "\\$_\{$v\}\n";
}
+ elsif ( defined $fields->{$_}->{'file'}
+ and $fields->{$_}->{'file'} eq 'true' )
+ {
+ my $v = $this{$_};
+ $v = '' if not defined $v;
+ print "\\$_\{$v\}\n";
+ }
else {
my $v = $this{$_};
- if (defined $v) {
+ if ( defined $v ) {
$v = "\n " + $v + "\n";
- } else {
+ }
+ 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";
-}
-
-#------------------------------------------------------------------------------
# Local Variables:
# mode: perl
# End:
Modified: trunk/Master/texmf-dist/source/support/ctan-o-mat/ctan-o-mat.bat
===================================================================
--- trunk/Master/texmf-dist/source/support/ctan-o-mat/ctan-o-mat.bat 2017-11-25 20:59:01 UTC (rev 45906)
+++ trunk/Master/texmf-dist/source/support/ctan-o-mat/ctan-o-mat.bat 2017-11-25 20:59:19 UTC (rev 45907)
@@ -1,21 +1,21 @@
- at echo off
- at rem --------------------------------------------------------------------------
- at rem This file is part of ctan-o-mat.
- at rem This program is distributed under BSD-like license. See file LICENSE
- at rem
- at rem (c) 2016-2017 Gerd Neugebauer
- at rem
- at rem Net: gene at gerd-neugebauer.de
- at rem
- at rem This program is free software; you can redistribute it and/or modify
- at rem it under the terms of a 3-clause BSD-like license as stated in the
- at rem file LICENSE contained in this distribution.
- at rem
- at rem You should have received a copy of the LICENSE along with this
- at rem program; if not, see the repository under http://***.
- at rem
- at rem --------------------------------------------------------------------------
-
-"perl ctan-o-mat.pl %*"
-
- at rem --------------------------------------------------------------------------
+ at echo off
+ at rem --------------------------------------------------------------------------
+ at rem This file is part of ctan-o-mat.
+ at rem This program is distributed under BSD-like license. See file LICENSE
+ at rem
+ at rem (c) 2016-2017 Gerd Neugebauer
+ at rem
+ at rem Net: gene at gerd-neugebauer.de
+ at rem
+ at rem This program is free software; you can redistribute it and/or modify
+ at rem it under the terms of a 3-clause BSD-like license as stated in the
+ at rem file LICENSE contained in this distribution.
+ at rem
+ at rem You should have received a copy of the LICENSE along with this
+ at rem program; if not, see the repository under http://***.
+ at rem
+ at rem --------------------------------------------------------------------------
+
+"perl ctan-o-mat.pl %*"
+
+ at rem --------------------------------------------------------------------------
More information about the tex-live-commits
mailing list