File Coverage

blib/lib/HTTP/Recorder.pm

Criterion	Covered	Total	%
statement	22	24	91.6
branch			n/a
condition			n/a
subroutine	8	8	100.0
pod			n/a
total	30	32	93.7

line

stmt

bran

cond

sub

pod

time

code

1

package HTTP::Recorder;

2

3

our $VERSION = "0.07";

4

5

=head1 NAME

6

7

HTTP::Recorder - record interaction with websites

8

9

=head1 SYNOPSIS

10

11

=head2 This module is deprecated

12

13

It works by tagging links in a page, and then when a link is clicked

14

looking on the submitted tag to see which link was clicked

15

16

It can not handle Javascript-created links or JS manipulation of the page

17

so it works only for fairly static websites

18

19

For better options check out Selenium

20

21

Patchs are welcome, and I'll fix bugs as much as I can, but please don't

22

expect me to implement new features

23

24

=head2 Using HTTP::Recorder as a Web Proxy

25

26

Set HTTP::Recorder as the user agent for a proxy, and it rewrites HTTP

27

responses so that additional requests can be recorded.

28

29

=head3 The Proxy Script

30

31

For quick start, run the httprecorder script

32

33

httprecorder

34

35

This will open a local proxy on port 8080, and will dump the recorded traffic

36

to a file named http_traffic in the current directory. use the -help parameter

37

for usage info

38

39

Start the proxy script, then change the settings in your web browser

40

so that it will use this proxy for web requests. For more information

41

about proxy settings and the default port, see L.

42

43

The script will be recorded in the specified file, and can be viewed

44

and modified via the control panel.

45

46

For better control, use this example:

47

48

#!/usr/bin/perl

49

50

use HTTP::Proxy;

51

use HTTP::Recorder;

52

53

my $proxy = HTTP::Proxy->new();

54

55

# create a new HTTP::Recorder object

56

my $agent = new HTTP::Recorder;

57

58

# set the log file (optional)

59

$agent->file("/tmp/myfile");

60

61

# set HTTP::Recorder as the agent for the proxy

62

$proxy->agent( $agent );

63

64

# start the proxy

65

$proxy->start();

66

67

=head3 Start Recording

68

69

Now you can use your browser as your normally would, and your actions

70

will be recorded in the file you specified. Alternatively, you can

71

start recording from the Control Panel.

72

73

=head3 Using the Control Panel

74

75

If you have Javascript enabled in your browser, go to the

76

L control URL (http://http-recorder by default),

77

optionally type a URL into the "Goto page" field, and click "Go".

78

79

In the new window, interact with web sites as you normally do,

80

including typing a new address into the address field. The Control

81

Panel will be updated after each recorded action.

82

83

The Control Panel allows you to modify, delete, or save your script.

84

85

=head2 SSL sessions

86

87

As of version 0.03, L can record SSL sessions.

88

89

To begin recording an SSL session, go to the control URL

90

(http://http-recorder/ by default), and enter the initial URL.

91

Then, interact with the web site as usual.

92

93

=head2 Script output

94

95

By default, L outputs L scripts.

96

97

However, you can override HTTP::Recorder::Logger to output other types

98

of scripts.

99

=cut

2

36491

use strict;

2

8

2

143

2

17

use warnings;

2

4

2

124

2

3285

use LWP::UserAgent;

2

112695

2

112

2

1798

use HTML::TokeParser;

2

25084

2

76

2

1298

use HTTP::Recorder::Logger;

2

15

2

65

2

13

use URI::Escape qw(uri_escape uri_unescape);

2

2

2

130

2

2124

use URI::QueryParam;

2

1510

2

54

2

1619

use HTTP::Request::Params;

0

0

our @ISA = qw( LWP::UserAgent );

=head1 Functions

=head2 new

Creates and returns a new L 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 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, which generates L 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 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/

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};

# workaround: the content can be a simple string

if (not ref $content) {

$content =~ s/(?:^|(?<=\&))\Q$prefix\E-[^=]+=[^\&]*(\&|$)//g;

return $content;

}

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 '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 .= "\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 'head') {

# add the javascript to update the script, right after the head opening tag

$newcontent .= $self->script_update();

}

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 .= "\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 .= ("{prefix}-action\" value=\"submitform\">\n");

$fields .= ("{prefix}-formname\" value=\"$name\">\n");

$fields .= ("{prefix}-formnumber\" value=\"$number\">\n");

if ($https) {

$fields .= ("{prefix}-https\" value=\"$https\">\n");

}

return $fields;

}

sub get_start_page {

my $self = shift;

my $content = <

HTTP::Recorder Start Page

Start Recording

Type a url into the browser's adddress field to begin recording.

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 = <

HTTP::Recorder Control Panel

onLoad="javascript:scrollScriptAreaToEnd()"

>

Goto page:

660
661
662
663							Current Script:
664
665
666
667
668							$script
669
670
671
672
673
674
675
676
677
678
679
680
681							onClick="if (!confirm('Do you really want to delete the script?')){ return false; }">
682
683
684
685
686

EOF

return $content;

}

sub script_update {

my $self = shift;

my $url = "http://" . $self->control . "/";

my $js = <

// 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

}

=head1 Bugs, Missing Features, and other Oddities

=head2 Javascript

L can't play back Javascript actions, and

L 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, L, L.

=head1 Requests & Bugs

Please submit any feature requests, suggestions, bugs, or patches at

http://rt.cpan.org/, or email to bug-HTTP-Recorder@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 Author

Copyright 2003-2005 by Linda Julien

Maintained by Shmuel Fomberg

Released under the GNU Public License.

=cut

1;