move tlperl.straw to tlperl

git-svn-id: svn://tug.org/texlive/trunk@18210 c570f23f-e606-0410-a88d-b1316a301751

1 files changed, 68 insertions, 0 deletions

diff --git a/Master/tlpkg/tlperl/lib/URI/pop.pm b/Master/tlpkg/tlperl/lib/URI/pop.pm
new file mode 100755
index 00000000000..50b8d6dd511
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/URI/pop.pm
@@ -0,0 +1,68 @@
+package URI::pop;   # RFC 2384
+
+require URI::_server;
+@ISA=qw(URI::_server);
+
+use strict;
+use URI::Escape qw(uri_unescape);
+
+sub default_port { 110 }
+
+#pop://<user>;auth=<auth>@<host>:<port>
+
+sub user
+{
+    my $self = shift;
+    my $old = $self->userinfo;
+
+    if (@_) {
+	my $new_info = $old;
+	$new_info = "" unless defined $new_info;
+	$new_info =~ s/^[^;]*//;
+
+	my $new = shift;
+	if (!defined($new) && !length($new_info)) {
+	    $self->userinfo(undef);
+	} else {
+	    $new = "" unless defined $new;
+	    $new =~ s/%/%25/g;
+	    $new =~ s/;/%3B/g;
+	    $self->userinfo("$new$new_info");
+	}
+    }
+
+    return unless defined $old;
+    $old =~ s/;.*//;
+    return uri_unescape($old);
+}
+
+sub auth
+{
+    my $self = shift;
+    my $old = $self->userinfo;
+
+    if (@_) {
+	my $new = $old;
+	$new = "" unless defined $new;
+	$new =~ s/(^[^;]*)//;
+	my $user = $1;
+	$new =~ s/;auth=[^;]*//i;
+
+	
+	my $auth = shift;
+	if (defined $auth) {
+	    $auth =~ s/%/%25/g;
+	    $auth =~ s/;/%3B/g;
+	    $new = ";AUTH=$auth$new";
+	}
+	$self->userinfo("$user$new");
+	
+    }
+
+    return unless defined $old;
+    $old =~ s/^[^;]*//;
+    return uri_unescape($1) if $old =~ /;auth=(.*)/i;
+    return;
+}
+
+1;