r9147 - in /branches/upstream/libhttp-recorder-perl: ./ current/ current/lib/ current/lib/HTTP/ current/lib/HTTP/Recorder/ current/t/
emhn-guest at users.alioth.debian.org
emhn-guest at users.alioth.debian.org
Fri Nov 9 23:13:56 UTC 2007
Author: emhn-guest
Date: Fri Nov 9 23:13:55 2007
New Revision: 9147
URL: http://svn.debian.org/wsvn/?sc=1&rev=9147
Log:
[svn-inject] Installing original source of libhttp-recorder-perl
Added:
branches/upstream/libhttp-recorder-perl/
branches/upstream/libhttp-recorder-perl/current/
branches/upstream/libhttp-recorder-perl/current/CHANGES
branches/upstream/libhttp-recorder-perl/current/MANIFEST
branches/upstream/libhttp-recorder-perl/current/META.yml
branches/upstream/libhttp-recorder-perl/current/Makefile.PL
branches/upstream/libhttp-recorder-perl/current/README
branches/upstream/libhttp-recorder-perl/current/lib/
branches/upstream/libhttp-recorder-perl/current/lib/HTTP/
branches/upstream/libhttp-recorder-perl/current/lib/HTTP/Recorder/
branches/upstream/libhttp-recorder-perl/current/lib/HTTP/Recorder.pm
branches/upstream/libhttp-recorder-perl/current/lib/HTTP/Recorder/Logger.pm
branches/upstream/libhttp-recorder-perl/current/t/
branches/upstream/libhttp-recorder-perl/current/t/load.t
branches/upstream/libhttp-recorder-perl/current/t/pod.t
Added: branches/upstream/libhttp-recorder-perl/current/CHANGES
URL: http://svn.debian.org/wsvn/branches/upstream/libhttp-recorder-perl/current/CHANGES?rev=9147&op=file
==============================================================================
--- branches/upstream/libhttp-recorder-perl/current/CHANGES (added)
+++ branches/upstream/libhttp-recorder-perl/current/CHANGES Fri Nov 9 23:13:55 2007
@@ -1,0 +1,90 @@
+Revision history for HTTP::Recorder
+-----------------------------------
+
+0.05 17 August 2005
+ Fixed a bug where link text wasn't being un-escaped before being
+ logged.
+
+ Significant changes in the use of the Control Panel:
+ - The showwindow option is gone (no popups any more).
+ - If you want to use the control panel, you need to start there.
+ - The control panel now spawns a window for navigation.
+ - The navigation window updates the Control Panel via Javascript.
+
+ Download button downloads the script file directly.
+
+0.04 17 August 2005
+ Parse and manipulate parameters with URI::QueryParam and
+ HTTP::Request::Params, rather than doing it by hand.
+
+0.03_03 16 August 2005
+ Several improvements to the Control Panel UI
+ - background color for easier reading
+ - script textarea resizes with window
+ - JavaScript confirmation before deleting script
+
+ Recording changes
+ - Log 0, false, and empty values
+ - Use click() instead of submit_form()
+
+ Changed the format of the %fields argument to
+ Logger::SetFieldsAndSubmit. This is unlikely to affect you unless
+ you've made a subclass or are using that method directly.
+
+0.03_02 9 August 2005
+
+ Support forms with multiple Submit buttons.
+
+ Always use single quotes around arguments.
+
+ Applied a patch from alex at kapranoff.ru (rt.cpan.org #6711) to
+ optionally ignore gets for favicon.ico. On by default.
+
+ Applied a patch from alex at kapranoff.ru (rt.cpan.org #6646) so
+ that the output script doesn't try to set hidden fields.
+
+0.03_01 1 March 2004
+
+ Support for recording SSL
+
+ Added a UI
+ - Available via control URL rather than a JS popup
+ - Update, reset clear, download features
+ - "Goto page" functionality
+
+ Rewriting improvements
+ - Support 'link' tag
+ - Support link anchors
+ - Set base URL if necessary (so relative links will be properly followed)
+ - Don't try to set the value of submit buttons in a form
+ - support multipart/form-data
+
+ Additional documentation
+
+ Logging improvements
+ - Add SetFieldsAndSubmit method to Logger; use it
+ - Set form name before trying to set form fields.
+ - Use form names when available, rather than form numbers.
+
+0.02 15 February 2004
+
+ Improved rewriting for pages with JavaScript:
+ - Don't rewrite href="javascript:XXX" links or text inside them
+ - Change the way forms are re-written, so that JavaScript won't fail.
+
+ Use link indices as well as names (supports multiple links of the
+ same name on a single page).
+
+ Preserve page titles.
+
+ Use form names when available, rather than form numbers.
+
+ Keep attributes in their original order on rewrite.
+
+ Support links with quotes (") in them.
+
+ Only try to rewrite text/ content (images, etc. won't be
+ corrupted).
+
+ ** Many thanks to Jason Gessner <jason at multiply.org> for his
+ patches and feedback.
Added: branches/upstream/libhttp-recorder-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/branches/upstream/libhttp-recorder-perl/current/MANIFEST?rev=9147&op=file
==============================================================================
--- branches/upstream/libhttp-recorder-perl/current/MANIFEST (added)
+++ branches/upstream/libhttp-recorder-perl/current/MANIFEST Fri Nov 9 23:13:55 2007
@@ -1,0 +1,9 @@
+lib/HTTP/Recorder.pm
+lib/HTTP/Recorder/Logger.pm
+Makefile.PL
+t/load.t
+t/pod.t
+MANIFEST
+CHANGES
+README
+META.yml Module meta-data (added by MakeMaker)
Added: branches/upstream/libhttp-recorder-perl/current/META.yml
URL: http://svn.debian.org/wsvn/branches/upstream/libhttp-recorder-perl/current/META.yml?rev=9147&op=file
==============================================================================
--- branches/upstream/libhttp-recorder-perl/current/META.yml (added)
+++ branches/upstream/libhttp-recorder-perl/current/META.yml Fri Nov 9 23:13:55 2007
@@ -1,0 +1,14 @@
+#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
+name: HTTP-Recorder
+version: 0.05
+version_from: lib/HTTP/Recorder.pm
+installdirs: site
+requires:
+ LWP::UserAgent: 0
+ HTTP::Request::Params: 0
+ URI::QueryParam: 0
+ URI::Escape: 0
+ HTML::TokeParser: 0
+
+distribution_type: module
+generated_by: ExtUtils::MakeMaker version 6.12
Added: branches/upstream/libhttp-recorder-perl/current/Makefile.PL
URL: http://svn.debian.org/wsvn/branches/upstream/libhttp-recorder-perl/current/Makefile.PL?rev=9147&op=file
==============================================================================
--- branches/upstream/libhttp-recorder-perl/current/Makefile.PL (added)
+++ branches/upstream/libhttp-recorder-perl/current/Makefile.PL Fri Nov 9 23:13:55 2007
@@ -1,0 +1,15 @@
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+ NAME => 'HTTP::Recorder',
+ VERSION_FROM => 'lib/HTTP/Recorder.pm', # finds $VERSION
+ AUTHOR => 'Linda Julien (leira at cpan.org)',
+ PREREQ_PM => { LWP::UserAgent => 0,
+ HTML::TokeParser => 0,
+ URI::Escape => 0,
+ URI::QueryParam => 0,
+ HTTP::Request::Params => 0,
+ },
+ ABSTRACT => '',
+);
Added: branches/upstream/libhttp-recorder-perl/current/README
URL: http://svn.debian.org/wsvn/branches/upstream/libhttp-recorder-perl/current/README?rev=9147&op=file
==============================================================================
--- branches/upstream/libhttp-recorder-perl/current/README (added)
+++ branches/upstream/libhttp-recorder-perl/current/README Fri Nov 9 23:13:55 2007
@@ -1,0 +1,25 @@
+HTTP::Recorder
+--------------
+
+WHAT THIS IS
+
+This is a browser-independent recorder for recording interactions with
+web sites.
+
+INSTALLATION
+
+Set HTTP::Recorder as the agent for your web proxy.
+
+Optionally, it uses javascript to open a window to display the script.
+
+PROBLEMS
+
+This software is barely out of the "proof of concept" stage. Caveat
+user.
+
+AUTHOR
+
+Copyright 2003-2004 by Linda Julien <leira at cpan.org>
+
+Released under the GNU Public License.
+
Added: branches/upstream/libhttp-recorder-perl/current/lib/HTTP/Recorder.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libhttp-recorder-perl/current/lib/HTTP/Recorder.pm?rev=9147&op=file
==============================================================================
--- branches/upstream/libhttp-recorder-perl/current/lib/HTTP/Recorder.pm (added)
+++ branches/upstream/libhttp-recorder-perl/current/lib/HTTP/Recorder.pm Fri Nov 9 23:13:55 2007
@@ -1,0 +1,755 @@
+package HTTP::Recorder;
+
+our $VERSION = "0.05";
+
+=head1 NAME
+
+HTTP::Recorder - record interaction with websites
+
+=head1 VERSION
+
+Version 0.05
+
+=head1 SYNOPSIS
+
+=head2 Using HTTP::Recorder as a Web Proxy
+
+Set HTTP::Recorder as the user agent for a proxy, and it rewrites HTTP
+responses so that additional requests can be recorded.
+
+=head3 The Proxy Script
+
+Set it up like this:
+
+ #!/usr/bin/perl
+
+ use HTTP::Proxy;
+ use HTTP::Recorder;
+
+ my $proxy = HTTP::Proxy->new();
+
+ # create a new HTTP::Recorder object
+ my $agent = new HTTP::Recorder;
+
+ # set the log file (optional)
+ $agent->file("/tmp/myfile");
+
+ # set HTTP::Recorder as the agent for the proxy
+ $proxy->agent( $agent );
+
+ # start the proxy
+ $proxy->start();
+
+ 1;
+
+Start the proxy script, then change the settings in your web browser
+so that it will use this proxy for web requests. For more information
+about proxy settings and the default port, see L<HTTP::Proxy>.
+
+The script will be recorded in the specified file, and can be viewed
+and modified via the control panel.
+
+=head3 Start Recording
+
+Now you can use your browser as your normally would, and your actions
+will be recorded in the file you specified. Alternatively, you can
+start recording from the Control Panel.
+
+=head3 Using the Control Panel
+
+If you have Javascript enabled in your browser, go to the
+L<HTTP::Recorder> control URL (http://http-recorder by default),
+optionally type a URL into the "Goto page" field, and click "Go".
+
+In the new window, interact with web sites as you normally do,
+including typing a new address into the address field. The Control
+Panel will be updated after each recorded action.
+
+The Control Panel allows you to modify, delete, or save your script.
+
+=head2 SSL sessions
+
+As of version 0.03, L<HTTP::Recorder> can record SSL sessions.
+
+To begin recording an SSL session, go to the control URL
+(http://http-recorder/ by default), and enter the initial URL.
+Then, interact with the web site as usual.
+
+=head2 Script output
+
+By default, L<HTTP::Recorder> outputs L<WWW::Mechanize> scripts.
+
+However, you can override HTTP::Recorder::Logger to output other types
+of scripts.
+
+=cut
+
+use strict;
+use warnings;
+use LWP::UserAgent;
+use HTML::TokeParser;
+use HTTP::Recorder::Logger;
+use URI::Escape qw(uri_escape uri_unescape);
+use URI::QueryParam;
+use HTTP::Request::Params;
+
+our @ISA = qw( LWP::UserAgent );
+
+=head1 Functions
+
+=head2 new
+
+Creates and returns a new L<HTTP::Recorder> object, referred to as the 'agent'.
+
+=cut
+
+sub new {
+ my $class = shift;
+
+ my %args = ( @_ );
+
+ my $self = $class->SUPER::new( %args );
+ bless $self, $class;
+
+ $self->{prefix} = $args{prefix} || "rec";
+ $self->{control} = $args{control} || "http-recorder";
+ $self->{logger} = $args{logger} ||
+ new HTTP::Recorder::Logger(file => $args{file});
+ $self->{ignore_favicon} = $args{ignore_favicon} || 1;
+
+ return $self;
+}
+
+=head2 $agent->prefix([$value])
+
+Get or set the prefix string that L<HTTP::Recorder> uses for rewriting
+responses.
+
+=cut
+
+sub prefix { shift->_elem('prefix', @_); }
+
+=head2 $agent->control([$value])
+
+Get or set the URL of the control panel. By default, the control URL
+is 'http-recorder'.
+
+The control URL will display a control panel which will allow you to
+view and edit the current script.
+
+=cut
+
+sub control { shift->_elem('control', @_); }
+
+=head2 $agent->logger([$value])
+
+Get or set the logger object. The default logger is a
+L<HTTP::Recorder::Logger>, which generates L<WWW::Mechanize> scripts.
+
+=cut
+
+sub logger {
+ my $self = shift;
+ $self->_elem('logger', @_);
+}
+
+=head2 $agent->ignore_favicon([0|1])
+
+Get or set ignore_favicon flag that causes L<HTTP::Recorder> to skip
+logging requests favicon.ico files. The value is 1 by default.
+
+=cut
+
+sub ignore_favicon { shift->_elem('ignore_favicon', @_); }
+
+=head2 $agent->file([$value])
+
+Get or set the filename for generated scripts. The default is
+'/tmp/scriptfile'.
+
+=cut
+
+sub file {
+ my $self = shift;
+ my $file = shift;
+
+ $self->{logger}->file($file) if $file;
+}
+
+sub send_request {
+ my $self = shift;
+ my $request = shift;
+
+ my $response;
+
+ # special handling if the URL is the control URL
+ if ($request->uri->host eq $self->{control}) {
+
+ # get the arguments passed from the form
+ my $arghash;
+ $arghash = extract_values($request);
+
+ # there may be an action we need to perform
+ if (exists $arghash->{updatescript}) {
+ my $script = $arghash->{ScriptContent};
+ $self->{logger}->SetScript($script || '');
+ } elsif (exists $arghash->{clearscript}) {
+ $self->{logger}->SetScript("");
+ }
+
+ my ($h, $content);
+ if (exists $arghash->{goto}) {
+ my $url = $arghash->{url};
+
+ if ($url) {
+ my $r = new HTTP::Request("GET", $url);
+ my $response = $self->send_request( $r );
+
+ return $response;
+ } else {
+ $h = HTTP::Headers->new(Content_Type => 'text/html');
+ $content = $self->get_start_page();
+ }
+ } elsif (exists $arghash->{savescript}) {
+ $h = HTTP::Headers->new(Content_Type => 'text/plain',
+ Content_Disposition => 'attachment; filename=recorder-script.pl');
+ my @script = $self->{logger}->GetScript();
+ $content = join('', @script);
+ } else {
+ $h = HTTP::Headers->new(Content_Type => 'text/html');
+ $content = $self->get_recorder_content();
+ }
+
+ $response = HTTP::Response->new(200,
+ "",
+ $h,
+ $content,
+ );
+ } else {
+ $request = $self->modify_request ($request)
+ unless $self->{ignore_favicon}
+ && $request->uri->path =~ /favicon\.ico$/i;
+
+ $response = $self->SUPER::send_request( $request );
+
+ my $content_type = $response->headers->header('Content-type') || "";
+
+ # don't try to modify the content unless it's text/<something>
+ if ($content_type =~ m#^text/#i) {
+ $self->modify_response($response);
+ }
+ }
+
+ return $response;
+}
+
+sub modify_request {
+ my $self = shift;
+ my $request = shift;
+
+ my $values = extract_values($request);
+
+ # log the actions
+ my $action = $values->{"$self->{prefix}-action"};
+
+ my $referer = $request->headers->referer;
+ if (!$action) {
+ if (!$referer) {
+ my $uri = $self->unmodify($request->uri);;
+
+ # log a blank line to give the code a little breathing room
+ $self->{logger}->LogLine();
+ $self->{logger}->GotoPage(url => $uri);
+ }
+ } elsif ($action eq "follow") {
+ $self->{logger}->FollowLink(text => $values->{"$self->{prefix}-text"} || "",
+ index => $values->{"$self->{prefix}-index"} || "",
+ url => $values->{"$self->{prefix}-url"});
+ } elsif ($action eq "submitform") {
+ my %fields;
+ my ($btn_name, $btn_value, $btn_number);
+ foreach my $param (keys %$values) {
+ my %fieldhash;
+ my ($fieldtype, $fieldname);
+ if ($param =~ /^$self->{prefix}-form(\d+)-(\w+)-(.*)$/) {
+ $fieldtype = $2;
+ $fieldname = $3;
+
+ if ($fieldtype eq 'submit') {
+ next unless $values->{$fieldname};
+ $btn_name = $fieldname;
+ $btn_value = $values->{$fieldname};
+ } else {
+ next if ($fieldtype eq 'hidden');
+ next unless $fieldname && exists $values->{$fieldname};
+ $fieldhash{'name'} = $fieldname;
+ $fieldhash{'type'} = $fieldtype;
+ if (ref($values->{$fieldname}) eq 'ARRAY') {
+ my @tempvalues = @{$values->{$fieldname}};
+ for (my $i = 0 ; $i < scalar @tempvalues ; $i++) {
+ $fieldhash{'value'} = $tempvalues[$i];
+ my %temphash = %fieldhash;
+ $fields{"$fieldname-$i"} = \%temphash;
+ }
+ } else {
+ $fieldhash{'value'} = $values->{$fieldname};
+ $fields{$fieldname} = \%fieldhash;
+ }
+ }
+ }
+ }
+
+ $self->{logger}->SetFieldsAndSubmit(name => $values->{"$self->{prefix}-formname"},
+ number => $values->{"$self->{prefix}-formnumber"},
+ fields => \%fields,
+ button_name => $btn_name,
+ button_value => $btn_value);
+
+ # log a blank line to give the code a little breathing room
+ $self->{logger}->LogLine();
+ }
+
+ # undo what we've done
+ $request->uri($self->unmodify($request->uri));
+ $request->content($self->unmodify($request->content));
+
+ # reset the Content-Length (if needed) to prevent warnings from
+ # HTTP::Protocol
+ if ($action && ($action eq "submitform")) {
+ $request->headers->header('Content-Length' => length($request->content()) );
+
+ }
+
+ my $https = $values->{"$self->{prefix}-https"};
+ if ( $https && $https == 1) {
+ my $uri = $request->uri;
+ $uri->scheme('https') if $uri->scheme eq 'http';
+
+ $request = new HTTP::Request($request->method,
+ $uri,
+ $request->headers,
+ $request->content);
+
+ }
+
+ return $request;
+}
+
+sub unmodify {
+ my $self = shift;
+ my $content = shift;
+
+ return $content unless $content;
+
+ # get rid of the arguments we added
+ my $prefix = $self->{prefix};
+
+ for my $key ($content->query_param) {
+ if ($key =~ /^$prefix-/) {
+ $content->query_param_delete($key);
+ }
+ }
+ return $content;
+}
+
+sub extract_values {
+ my $request = shift;
+
+ my $parser = HTTP::Request::Params->new({
+ req => $request,
+ });
+
+ # un-escape all params
+ for my $key (keys %{$parser->params}) {
+ $parser->params->{$key} = uri_unescape($parser->params->{$key});
+ }
+
+ return $parser->params;
+}
+
+sub modify_response {
+ my $self = shift;
+ my $response = shift;
+ my $formcount = 0;
+ my $formnumber = 0;
+ my $linknumber = 1;
+
+ $response->headers->push_header('Cache-Control', 'no-store, no-cache');
+ $response->headers->push_header('Pragma', 'no-cache');
+
+ my $content = $response->content();
+ my $p = HTML::TokeParser->new(\$content);
+ my $newcontent = "";
+ my %links;
+ my $formname;
+
+ my $js_href = 0;
+ my $in_head = 0;
+ my $basehref;
+ while (my $token = $p->get_token()) {
+ if (@$token[0] eq 'S') {
+ my $tagname = @$token[1];
+ my $attrs = @$token[2];
+ my $oldaction;
+ my $text;
+
+ if ($tagname eq 'head') {
+ $in_head = 1;
+ } elsif ($in_head && $tagname eq 'base') {
+ $basehref = new URI($attrs->{'base'});
+ } elsif ($tagname eq 'html') {
+ # add the javascript to update the script
+ $newcontent .= $self->script_update();
+ } elsif (($tagname eq 'a' || $tagname eq 'link') &&
+ $attrs->{'href'}) {
+ my $t = $p->get_token();
+ if (@$t[0] eq 'T') {
+ $text = @$t[1];
+ } else {
+ undef $text;
+ }
+ $p->unget_token($t);
+
+ # up the counter for links with the same text
+ my $index;
+ if (defined $text) {
+ $links{$text} = 0 if !(exists $links{$text});
+ $links{$text}++;
+ $index = $links{$text};
+ } else {
+ $index = $linknumber;
+ }
+ if ($attrs->{'href'} =~ m/^javascript:/i) {
+ $js_href = 1;
+ } else {
+ if ($tagname eq 'a') {
+ $attrs->{'href'} =
+ $self->rewrite_href($attrs->{'href'},
+ $text,
+ $index,
+ $response->base);
+ } elsif ($tagname eq 'link') {
+ $attrs->{'href'} =
+ $self->rewrite_linkhref($attrs->{'href'},
+ $response->base);
+ }
+ }
+ $linknumber++;
+ } elsif ($tagname eq 'form') {
+ $formcount++;
+ $formnumber++;
+ }
+
+ # put the hidden field before the real field
+ # so that it won't be inside
+ if (!$js_href &&
+ $tagname ne 'form' && ($formcount == 1)) {
+ my ($formfield, $fieldprefix, $fieldtype, $fieldname);
+ $fieldprefix = "$self->{prefix}-form" . $formnumber;
+ $fieldtype = lc($attrs->{type}) || 'unknown';
+ if ($attrs->{name}) {
+ $fieldname = $attrs->{name};
+ $formfield = ($fieldprefix . '-' .
+ $fieldtype . '-' . $fieldname);
+ $newcontent .= "<input type=\"hidden\" name=\"$formfield\" value=1>\n";
+ }
+ }
+
+ $newcontent .= ("<".$tagname);
+
+ # keep the attributes in their original order
+ my $attrlist = @$token[3];
+ foreach my $attr (@$attrlist) {
+ # only rewrite if
+ # - it's not part of a javascript link
+ # - it's not a hidden field
+ $newcontent .= (" ".$attr."=\"".$attrs->{$attr}."\"");
+ }
+ $newcontent .= (">\n");
+ if ($tagname eq 'form') {
+ if ($formcount == 1) {
+ $newcontent .= $self->rewrite_form_content($attrs->{name} || "",
+ $formnumber,
+ $response->base);
+ }
+ }
+ } elsif (@$token[0] eq 'E') {
+ my $tagname = @$token[1];
+ if ($tagname eq 'head') {
+ if (!$basehref) {
+ $basehref = $response->base;
+ $basehref->scheme('http') if $basehref->scheme eq 'https';
+ $newcontent .= "<base href=\"" . $basehref . "\">\n";
+ }
+ $basehref = "";
+ $in_head = 0;
+ }
+ $newcontent .= ("</");
+ $newcontent .= ($tagname.">\n");
+ if ($tagname eq 'form') {
+ $formcount--;
+ } elsif ($tagname eq 'a' || $tagname eq 'link') {
+ $js_href = 0;
+ }
+ } elsif (@$token[0] eq 'PI') {
+ $newcontent .= (@$token[2]);
+ } else {
+ $newcontent .= (@$token[1]);
+ }
+ }
+
+ $response->content($newcontent);
+
+ return;
+}
+
+sub rewrite_href {
+ my $self = shift;
+ my $href = shift || "";
+ my $text = shift || "";
+ my $index = shift || 1;
+ my $base = shift;
+
+ my $newhref = new URI($href);
+ my $prefix = $self->{prefix};
+
+ if ($base->scheme eq 'https') {
+ $newhref->query_param_append( "$prefix-https", 1);
+ $newhref->scheme('http');
+ }
+
+ # the original URL
+ $newhref->query_param_append( "$prefix-url", uri_escape($href));
+
+ # the action (i.e. follow link)
+ $newhref->query_param_append( "$prefix-action", 'follow');
+
+ # the link information
+ $text = uri_escape($text); # might have special characters
+ $newhref->query_param_append( "$prefix-text", $text);
+ $newhref->query_param_append( "$prefix-index", $index);
+
+ return $newhref;
+}
+
+sub rewrite_linkhref {
+ my $self = shift;
+ my $href = shift || "";
+ my $base = shift;
+
+ my $newhref = new URI($href);
+ my $prefix = $self->{prefix};
+
+ $newhref->query_param_append( "$prefix-https", 1)
+ if $base->scheme eq 'https';
+
+ # the original URL
+ $newhref->query_param_append( "$prefix-url", uri_escape($href));
+
+ # the action (i.e. don't record)
+ $newhref->query_param_append( "$prefix-action", 'norecord');
+
+ return $newhref;
+}
+
+sub rewrite_form_content {
+ my $self = shift;
+ my $name = shift || "";
+ my $number = shift;
+ my $url = shift;
+ my $fields;
+
+ my $https = 1 if ($url->scheme eq 'https');
+
+ $fields .= ("<input type=hidden name=\"$self->{prefix}-action\" value=\"submitform\">\n");
+ $fields .= ("<input type=hidden name=\"$self->{prefix}-formname\" value=\"$name\">\n");
+ $fields .= ("<input type=hidden name=\"$self->{prefix}-formnumber\" value=\"$number\">\n");
+ if ($https) {
+ $fields .= ("<input type=hidden name=\"$self->{prefix}-https\" value=\"$https\">\n");
+ }
+
+ return $fields;
+}
+
+sub get_start_page {
+ my $self = shift;
+
+ my $content = <<EOF;
+<html>
+<head>
+<title>HTTP::Recorder Start Page</title>
+<SCRIPT LANGUAGE="JavaScript">
+<!-- // start
+ self.focus(); // bring this window to the front
+// end -->
+</SCRIPT>
+</head>
+<body>
+<h1>Start Recording</h1>
+<p>Type a url into the browser's adddress field to begin recording.
+</html>
+EOF
+
+ return $content;
+}
+
+sub get_recorder_content {
+ my $self = shift;
+
+ my @script = $self->{logger}->GetScript();
+ my $script = "";
+ foreach my $line (@script) {
+ next unless $line;
+ $line =~ s/\n//g;
+ $script .= "$line\n";
+ }
+
+ my $content = <<EOF;
+<SCRIPT LANGUAGE="JavaScript">
+<!-- // start
+function scrollScriptAreaToEnd() {
+ scriptarea = document.forms['ScriptForm'].elements['ScriptContent'];
+ scriptarea.scrollTop = scriptarea.scrollHeight;
+ scriptarea.focus();
+}
+// end -->
+</SCRIPT>
+
+<html>
+<head>
+<title>HTTP::Recorder Control Panel</title>
+<STYLE type="text/css">
+ table {font-family:Helvetica,sans-serif; font-size:14px}
+ input {font-family:Helvetica,sans-serif; font-size:12px}
+ </STYLE>
+</head>
+<body bgcolor="lightgrey"
+ onLoad="javascript:scrollScriptAreaToEnd()"
+>
+<table width=100% height=98%>
+<FORM name="GotoForm" method="POST" action="http://$self->{control}/" target="recording">
+ <tr>
+ <td>
+ Goto page: <input name="url" size=30>
+ <input type=submit name="goto" value="Go">
+ <hr>
+ </td>
+ </tr>
+</FORM>
+ <tr>
+ <td width="100%" height="100%">
+ <table width="100%" height="100%">
+ <FORM name="ScriptForm" method="POST" action="http://$self->{control}/">
+ <tr>
+ <td>
+Current Script:
+ </td>
+ </tr>
+ <tr>
+ <td height=100%>
+<textarea style="font-size: 10pt;font-family:monospace;width:100%;height:100%" name="ScriptContent">$script</textarea>
+ </td>
+ </tr>
+ <tr>
+ <td align=center>
+ <INPUT TYPE="SUBMIT" name="updatescript" VALUE="Apply">
+ <INPUT TYPE="RESET">
+ <INPUT TYPE="BUTTON" VALUE="Refresh" onClick="window.location='http://$self->{control}/'">
+ </td>
+ </tr>
+ <tr>
+ <td align=center>
+ <INPUT TYPE="SUBMIT" name="clearscript" VALUE="Delete"
+ onClick="if (!confirm('Do you really want to delete the script?')){ return false; }">
+ <INPUT TYPE="SUBMIT" name="savescript" VALUE="Save As">
+ </td>
+ </tr>
+ </FORM>
+ </table>
+ </td>
+ </tr>
+ </table>
+</body></html>
+EOF
+
+ return $content;
+}
+
+sub script_update {
+ my $self = shift;
+
+ my $url = "http://" . $self->control . "/";
+ my $js = <<EOF;
+// find the top-level opener window
+var opwindow = window.opener;
+while (opwindow.opener) {
+ opwindow = opwindow.opener;
+}
+// update it with HTTP::Recorder's control panel
+if (opwindow) {
+ opwindow.location = "http://http-recorder/";
+}
+EOF
+
+return <<EOF;
+<SCRIPT LANGUAGE="JavaScript">
+<!-- // start
+$js
+// end -->
+</SCRIPT>
+EOF
+}
+
+=head1 Bugs, Missing Features, and other Oddities
+
+=head2 Javascript
+
+L<WWW::Mechanize> can't play back Javascript actions, and
+L<HTTP::Recorder> doesn't record them.
+
+=head2 Why are my images corrupted?
+
+HTTP::Recorder only tries to rewrite responses that are of type
+text/*, which it determines by reading the Content-Type header of the
+HTTP::Response object. However, if the received image gives the wrong
+Content-Type header, it may be corrupted by the recorder. While this
+may not be pleasant to look at, it shouldn't have an effect on your
+recording session.
+
+=head1 See Also
+
+See also L<LWP::UserAgent>, L<WWW::Mechanize>, L<HTTP::Proxy>.
+
+=head1 Requests & Bugs
+
+Please submit any feature requests, suggestions, bugs, or patches at
+http://rt.cpan.org/, or email to bug-HTTP-Recorder at rt.cpan.org.
+
+If you're submitting a bug of the type "X doesn't record correctly,"
+be sure to include a (preferably short and simple) HTML page that
+demonstrates the problem, and a clear explanation of a) what it does
+that it shouldn't, and b) what it should do instead.
+
+=head1 More information
+
+You can read more about L<HTTP::Recorder>, including browsing the
+current source tree, at http://www.bitmistress.org/.
+
+There's a mailing list for users and developers of HTTP::Recorder.
+You can subscribe at
+http://lists.fsck.com/mailman/listinfo/http-recorder, or by sending
+email to http-recorder-request at lists.fsck.com with the subject
+"subscribe".
+
+Mailing list archives can be found at
+http://lists.fsck.com/pipermail/http-recorder.
+
+=head1 Author
+
+Copyright 2003-2005 by Linda Julien <leira at cpan.org>
+
+Released under the GNU Public License.
+
+=cut
+
+1;
Added: branches/upstream/libhttp-recorder-perl/current/lib/HTTP/Recorder/Logger.pm
URL: http://svn.debian.org/wsvn/branches/upstream/libhttp-recorder-perl/current/lib/HTTP/Recorder/Logger.pm?rev=9147&op=file
==============================================================================
--- branches/upstream/libhttp-recorder-perl/current/lib/HTTP/Recorder/Logger.pm (added)
+++ branches/upstream/libhttp-recorder-perl/current/lib/HTTP/Recorder/Logger.pm Fri Nov 9 23:13:55 2007
@@ -1,0 +1,251 @@
+package HTTP::Recorder::Logger;
+
+use strict;
+use warnings;
+use LWP::MemberMixin;
+our @ISA = qw( LWP::MemberMixin );
+
+sub new {
+ my $class = shift;
+
+ my %args = (
+ @_
+ );
+
+ my $self = bless ({}, ref ($class) || $class);
+
+ $self->{'file'} = $args{'file'} || "/tmp/scriptfile";
+
+ $self->{agentname} = "\$agent";
+
+ return $self;
+}
+
+sub agentname { shift->_elem('agentname', @_); }
+sub file { shift->_elem('file', @_); }
+
+sub GetScript {
+ my $self = shift;
+
+ if (open (SCRIPT, $self->{file})) {
+ my @script = <SCRIPT>;
+ close SCRIPT;
+ return @script;
+ } else {
+ return undef;
+ }
+}
+
+sub SetScript {
+ my $self = shift;
+ my $script = shift;
+
+ my $scriptfile = $self->{'file'};
+ open (SCRIPT, ">$scriptfile");
+ print SCRIPT $script;
+ close SCRIPT;
+}
+
+sub Log {
+ my $self = shift;
+ my $function = shift;
+ my $args = shift || '';
+
+ return unless $function;
+ my $line = $self->{agentname} . "->$function($args);\n";
+
+ my $scriptfile = $self->{'file'};
+ open (SCRIPT, ">>$scriptfile");
+ print SCRIPT $line;
+ close SCRIPT;
+}
+
+sub LogComment {
+ my $self = shift;
+ my $comment = shift;
+
+ my $scriptfile = $self->{'file'};
+ open (SCRIPT, ">>$scriptfile");
+ print SCRIPT "# $comment\n";
+ close SCRIPT;
+}
+
+sub LogLine {
+ my $self = shift;
+ my %args = (
+ line => "",
+ @_
+ );
+
+ my $scriptfile = $self->{'file'};
+ open (SCRIPT, ">>$scriptfile");
+ print SCRIPT $args{line}, "\n";
+ close SCRIPT;
+}
+
+sub GotoPage {
+ my $self = shift;
+ my %args = (
+ url => "",
+ @_
+ );
+
+ $self->Log("get", "'$args{url}'");
+}
+
+sub FollowLink {
+ my $self = shift;
+ my %args = (
+ text => "",
+ index => "",
+ @_
+ );
+
+ if ($args{text}) {
+ $args{text} =~ s/"/\\"/g;
+ $self->Log("follow_link",
+ "text => '$args{text}', n => '$args{index}'");
+ } else {
+ $self->Log("follow_link",
+ "n => '$args{index}'");
+ }
+}
+
+sub SetFieldsAndSubmit {
+ my $self = shift;
+ my %args = (
+ name => "",
+ number => undef,
+ fields => {},
+ button_name => {},
+ button_value => {},
+ button_number => {},
+ @_
+ );
+
+ $self->SetForm(name => $args{name}, number => $args{number});
+
+ my %fields = %{$args{'fields'}};
+ foreach my $field (keys %fields) {
+ if ($fields{$field}{'type'} eq 'checkbox') {
+ $self->Check(name => $fields{$field}{'name'},
+ value => $fields{$field}{'value'});
+ } else {
+ $self->SetField(name => $fields{$field}{'name'},
+ value => $fields{$field}{'value'});
+ }
+ }
+ # use click instead of submit
+ $self->Click(name => $args{name},
+ button_name => $args{button_name},
+ button_value => $args{button_value},
+ button_number => $args{button_number},
+ );
+}
+
+sub SetForm {
+ my $self = shift;
+ my %args = (
+ @_
+ );
+
+ if ($args{name}) {
+ $self->Log("form_name", "'$args{name}'");
+ } else {
+ $self->Log("form_number", $args{number});
+ }
+}
+
+sub SetField {
+ my $self = shift;
+ my %args = (
+ name => undef,
+ value => '',
+ @_
+ );
+
+ return unless $args{name};
+
+ # escape single quotes
+ $args{name} =~ s/'/\\'/g;
+ $args{value} =~ s/'/\\'/g;
+
+ $self->Log("field", "'$args{name}', '$args{value}'");
+}
+
+sub Check {
+ my $self = shift;
+ my %args = (
+ name => undef,
+ value => undef,
+ @_
+ );
+
+ return unless $args{name} && $args{value};
+
+ # escape single quotes
+ $args{name} =~ s/'/\\'/g;
+ $args{value} =~ s/'/\\'/g;
+
+ $self->Log("tick", "'$args{name}', '$args{value}'");
+}
+
+sub UnCheck {
+ my $self = shift;
+ my %args = (
+ name => undef,
+ value => undef,
+ @_
+ );
+
+ return unless $args{name} && $args{value};
+
+ # escape single quotes
+ $args{name} =~ s/'/\\'/g;
+ $args{value} =~ s/'/\\'/g;
+
+ $self->Log("untick", "'$args{name}', '$args{value}'");
+}
+
+sub Submit {
+ my $self = shift;
+ my %args = (
+ @_
+ );
+
+ my $submitargs = '';
+ if ($args{name}) {
+ $submitargs = "form_name => '$args{name}', ";
+ } elsif ($args{number}) {
+ $submitargs = "form_number => '$args{number}'";
+ }
+
+ $submitargs .= ', ' if $submitargs;
+
+ if ($args{button_name}) {
+ $submitargs .= "button => $args{button_name}";
+ }
+
+ # TODO: also support button value, number
+ # Don't add this until WWW::Mechanize supports it
+
+ $self->Log("submit_form", $submitargs);
+}
+
+sub Click {
+ my $self = shift;
+ my %args = (
+ @_
+ );
+
+ my $clickargs;
+ if ($args{button_name}) {
+ $clickargs = "'$args{button_name}'";
+ }
+
+ # TODO: also support button value, number
+ # Don't add this until WWW::Mechanize supports it
+ $self->Log("click", $clickargs);
+}
+
+1;
Added: branches/upstream/libhttp-recorder-perl/current/t/load.t
URL: http://svn.debian.org/wsvn/branches/upstream/libhttp-recorder-perl/current/t/load.t?rev=9147&op=file
==============================================================================
--- branches/upstream/libhttp-recorder-perl/current/t/load.t (added)
+++ branches/upstream/libhttp-recorder-perl/current/t/load.t Fri Nov 9 23:13:55 2007
@@ -1,0 +1,3 @@
+ use Test::More tests => 1;
+
+use_ok( 'HTTP::Recorder', "Loaded HTTP::Recorder" );
Added: branches/upstream/libhttp-recorder-perl/current/t/pod.t
URL: http://svn.debian.org/wsvn/branches/upstream/libhttp-recorder-perl/current/t/pod.t?rev=9147&op=file
==============================================================================
--- branches/upstream/libhttp-recorder-perl/current/t/pod.t (added)
+++ branches/upstream/libhttp-recorder-perl/current/t/pod.t Fri Nov 9 23:13:55 2007
@@ -1,0 +1,25 @@
+use Test::More;
+
+use File::Spec;
+use File::Find;
+use HTTP::Recorder;
+use strict;
+
+eval {
+ require Test::Pod;
+};
+
+my $ok = !$@ && ($Test::Pod::VERSION >= '0.95');
+
+if (!$ok) {
+ plan skip_all => "Test::Pod v0.95 required for testing POD";
+} else {
+ Test::Pod->import;
+ my @files;
+ my $blib = File::Spec->catfile(qw(blib lib));
+ find( sub {push @files, $File::Find::name if /\.p(l|m|od)$/}, $blib);
+ plan tests => scalar @files;
+ foreach my $file (@files) {
+ pod_file_ok($file, "POD file $file OK");
+ }
+}
More information about the Pkg-perl-cvs-commits
mailing list