| line | stmt | bran | cond | sub | pod | time | code | 
| 1 |  |  |  |  |  |  | package WWW::Sitebase::Navigator; | 
| 2 |  |  |  |  |  |  |  | 
| 3 | 2 |  |  | 2 |  | 12353 | use warnings; | 
|  | 2 |  |  |  |  | 2 |  | 
|  | 2 |  |  |  |  | 62 |  | 
| 4 | 2 |  |  | 2 |  | 6 | use strict; | 
|  | 2 |  |  |  |  | 3 |  | 
|  | 2 |  |  |  |  | 50 |  | 
| 5 | 2 |  |  | 2 |  | 6 | use WWW::Sitebase -Base; | 
|  | 2 |  |  |  |  | 1 |  | 
|  | 2 |  |  |  |  | 15 |  | 
| 6 | 2 |  |  | 2 |  | 7566 | use Carp; | 
|  | 2 |  |  | 2 |  | 2 |  | 
|  | 2 |  |  | 2 |  | 35 |  | 
|  | 2 |  |  |  |  | 6 |  | 
|  | 2 |  |  |  |  | 7 |  | 
|  | 2 |  |  |  |  | 44 |  | 
|  | 2 |  |  |  |  | 5 |  | 
|  | 2 |  |  |  |  | 4 |  | 
|  | 2 |  |  |  |  | 101 |  | 
| 7 | 2 |  |  | 2 |  | 1341 | use WWW::Mechanize; | 
|  | 2 |  |  |  |  | 185969 |  | 
|  | 2 |  |  |  |  | 71 |  | 
| 8 | 2 |  |  | 2 |  | 15 | use File::Spec::Functions; | 
|  | 2 |  |  |  |  | 3 |  | 
|  | 2 |  |  |  |  | 173 |  | 
| 9 | 2 |  |  | 2 |  | 640 | use Term::ReadKey; # For password prompt | 
|  | 2 |  |  |  |  | 3160 |  | 
|  | 2 |  |  |  |  | 4551 |  | 
| 10 |  |  |  |  |  |  |  | 
| 11 |  |  |  |  |  |  | =head1 NAME | 
| 12 |  |  |  |  |  |  |  | 
| 13 |  |  |  |  |  |  | WWW::Sitebase::Navigator - Base class for modules that navigate web sites | 
| 14 |  |  |  |  |  |  |  | 
| 15 |  |  |  |  |  |  | =head1 VERSION | 
| 16 |  |  |  |  |  |  |  | 
| 17 |  |  |  |  |  |  | Version 0.11 | 
| 18 |  |  |  |  |  |  |  | 
| 19 |  |  |  |  |  |  | =cut | 
| 20 |  |  |  |  |  |  |  | 
| 21 |  |  |  |  |  |  | our $VERSION = '0.11'; | 
| 22 |  |  |  |  |  |  |  | 
| 23 |  |  |  |  |  |  | =head1 SYNOPSIS | 
| 24 |  |  |  |  |  |  |  | 
| 25 |  |  |  |  |  |  | This module is a base class for modules that navigate web sites | 
| 26 |  |  |  |  |  |  | like Myspace or Bebo.  It provides basic methods like | 
| 27 |  |  |  |  |  |  | get_page and submit_form that are more robsut than their counterparts | 
| 28 |  |  |  |  |  |  | in WWW::Mechanize.  It also provides some core methods like "site_login". | 
| 29 |  |  |  |  |  |  | If you subclass this module and override the "site_info" method, | 
| 30 |  |  |  |  |  |  | you'll have a module that can log into your web site. Ta Da. | 
| 31 |  |  |  |  |  |  |  | 
| 32 |  |  |  |  |  |  | Note that this module is a subclass of "Spiffy" using "use Spiffy -Base". | 
| 33 |  |  |  |  |  |  | perldoc Spiffy for more info or look it up on CPAN. | 
| 34 |  |  |  |  |  |  | Most importantly this means we use Spiffy's "field" method to create | 
| 35 |  |  |  |  |  |  | accessor methods, you don't need to include "my $self = shift" | 
| 36 |  |  |  |  |  |  | in your methods, and you can use "super" to call the base class's | 
| 37 |  |  |  |  |  |  | version of an overridden method. | 
| 38 |  |  |  |  |  |  |  | 
| 39 |  |  |  |  |  |  | use WWW::Sitebase::Navigator -Base; | 
| 40 |  |  |  |  |  |  |  | 
| 41 |  |  |  |  |  |  | field site_info => { | 
| 42 |  |  |  |  |  |  | home_page => 'http://www.myspace.com', # URL of site's homepage | 
| 43 |  |  |  |  |  |  | account_field => 'email', # Fieldname from the login form | 
| 44 |  |  |  |  |  |  | password_field => 'password', # Password fieldname | 
| 45 |  |  |  |  |  |  | cache_dir => '.www-MYSITE', | 
| 46 |  |  |  |  |  |  | login_form_name => 'login', # The name of the login form.  OR | 
| 47 |  |  |  |  |  |  | login_form_no => 1, # The number of the login form (defaults to 1). | 
| 48 |  |  |  |  |  |  | # 1 is the first form on the page. | 
| 49 |  |  |  |  |  |  | login_verify_re => 'Welcome.*view my profile', # (optional) | 
| 50 |  |  |  |  |  |  | # Non-case-sensitive RE we should see once we're logged in | 
| 51 |  |  |  |  |  |  | not_logged_in_re => 'Sign In<\/title>', | 
| 52 |  |  |  |  |  |  | # If we log in and it fails (bad password, account suddenly | 
| 53 |  |  |  |  |  |  | # gets logged out), the page will have this RE on it. | 
| 54 |  |  |  |  |  |  | # Case insensitive. | 
| 55 |  |  |  |  |  |  | home_uri_re => '\?fuseaction=user&', | 
| 56 |  |  |  |  |  |  | # _go_home uses this and the next two items to load | 
| 57 |  |  |  |  |  |  | # the home page.  You can provide these options or | 
| 58 |  |  |  |  |  |  | # just override the method. | 
| 59 |  |  |  |  |  |  | # First, this is matched against the current URL to see if we're | 
| 60 |  |  |  |  |  |  | # already on the home page. | 
| 61 |  |  |  |  |  |  | home_link_re => 'fuseaction=user', | 
| 62 |  |  |  |  |  |  | # If we're not on the home page, this RE is | 
| 63 |  |  |  |  |  |  | # used to find a link to the "Home" button on the current | 
| 64 |  |  |  |  |  |  | # page. | 
| 65 |  |  |  |  |  |  | home_url => 'http://www.myspace.com?fuseaction=user', | 
| 66 |  |  |  |  |  |  | # If the "Home" button link isn't found, this URL is | 
| 67 |  |  |  |  |  |  | # retreived. | 
| 68 |  |  |  |  |  |  | error_regexs => [ | 
| 69 |  |  |  |  |  |  | 'An unexpected error has occurred', | 
| 70 |  |  |  |  |  |  | 'Site is temporarily down', | 
| 71 |  |  |  |  |  |  | 'We hired monkeys to program our site, please wait '. | 
| 72 |  |  |  |  |  |  | 'while they throw bananas at each other.' | 
| 73 |  |  |  |  |  |  | ], | 
| 74 |  |  |  |  |  |  | # error_regexs is optional.  If the site you're navigating | 
| 75 |  |  |  |  |  |  | # displays  error pages that do not return proper HTTP Status | 
| 76 |  |  |  |  |  |  | # codes (i.e. returns a 200 but displays an error), you can enter | 
| 77 |  |  |  |  |  |  | # REs here and any page that matches will be retried. | 
| 78 |  |  |  |  |  |  | # This is meant for IIS and ColdFusion-based sites that | 
| 79 |  |  |  |  |  |  | # periodically spew error messages that go away when tried again. | 
| 80 |  |  |  |  |  |  | }; | 
| 81 |  |  |  |  |  |  |  | 
| 82 |  |  |  |  |  |  | IMPORTANT:  If the site your module navigates uses ANY SSL, you'll | 
| 83 |  |  |  |  |  |  | need to add "Crypt::SSLEay" or "IO::Socket::SSL" to your list of prerequisite | 
| 84 |  |  |  |  |  |  | modules.  Otherwise your methods will die if they hit an SSL-encrypted page. | 
| 85 |  |  |  |  |  |  | WWW::Sitebase::Navigator doesn't require this for you to prevent unnecessary | 
| 86 |  |  |  |  |  |  | overhead for sites that don't need it. | 
| 87 |  |  |  |  |  |  |  | 
| 88 |  |  |  |  |  |  | =cut | 
| 89 |  |  |  |  |  |  |  | 
| 90 |  |  |  |  |  |  | # Where should we store files? (cookies, cache dir). We use, and untaint, | 
| 91 |  |  |  |  |  |  | # the user's home dir for the default. | 
| 92 | 0 |  |  | 0 |  |  | sub _home_dir { | 
| 93 | 0 |  |  |  |  |  | my $home_dir = ""; | 
| 94 | 0 | 0 |  |  |  |  | if ( defined $ENV{'HOME'} ) { | 
| 95 | 0 |  |  |  |  |  | $home_dir = "$ENV{'HOME'}"; | 
| 96 |  |  |  |  |  |  |  | 
| 97 | 0 | 0 |  |  |  |  | if ( $home_dir =~ /^([\-A-Za-z0-9_ \/\.@\+\\:]*)$/ ) { | 
| 98 | 0 |  |  |  |  |  | $home_dir = $1; | 
| 99 |  |  |  |  |  |  | } else { | 
| 100 | 0 |  |  |  |  |  | croak "Invalid characters in $ENV{HOME}."; | 
| 101 |  |  |  |  |  |  | } | 
| 102 |  |  |  |  |  |  | } | 
| 103 |  |  |  |  |  |  |  | 
| 104 | 0 |  |  |  |  |  | return $home_dir; | 
| 105 |  |  |  |  |  |  | } | 
| 106 |  |  |  |  |  |  |  | 
| 107 |  |  |  |  |  |  | =head1 OPTIONS | 
| 108 |  |  |  |  |  |  |  | 
| 109 |  |  |  |  |  |  | =head2 default_options | 
| 110 |  |  |  |  |  |  |  | 
| 111 |  |  |  |  |  |  | Override this method to allow additional options to be passed to | 
| 112 |  |  |  |  |  |  | "new".  You should also provide accessor methods for them. | 
| 113 |  |  |  |  |  |  | These are parsed by Params::Validate.  In breif, setting an | 
| 114 |  |  |  |  |  |  | option to "0" means it's optional, "1" means it's required. | 
| 115 |  |  |  |  |  |  | See Params::Validate for more info. | 
| 116 |  |  |  |  |  |  |  | 
| 117 |  |  |  |  |  |  | sub default_options { | 
| 118 |  |  |  |  |  |  | $self->{default_options}={ | 
| 119 |  |  |  |  |  |  | account_name => 0, | 
| 120 |  |  |  |  |  |  | password => 0, | 
| 121 |  |  |  |  |  |  | cache_dir => 0,  # Default set by site_info field method | 
| 122 |  |  |  |  |  |  | cache_file => 0, # Default set by field method below | 
| 123 |  |  |  |  |  |  | auto_login => 0, # Default set by field method below | 
| 124 |  |  |  |  |  |  | human => 0,      # Default set by field method below | 
| 125 |  |  |  |  |  |  | config_file => 0 | 
| 126 |  |  |  |  |  |  | }; | 
| 127 |  |  |  |  |  |  |  | 
| 128 |  |  |  |  |  |  | return $self->{default_options}; | 
| 129 |  |  |  |  |  |  | } | 
| 130 |  |  |  |  |  |  |  | 
| 131 |  |  |  |  |  |  | # So to add a "questions" option that's mandatory: | 
| 132 |  |  |  |  |  |  |  | 
| 133 |  |  |  |  |  |  | sub default_options { | 
| 134 |  |  |  |  |  |  | super; | 
| 135 |  |  |  |  |  |  | $self->{default_options}->{questions}=1; | 
| 136 |  |  |  |  |  |  | return $self->{default_options}; | 
| 137 |  |  |  |  |  |  | } | 
| 138 |  |  |  |  |  |  |  | 
| 139 |  |  |  |  |  |  | =cut | 
| 140 |  |  |  |  |  |  |  | 
| 141 |  |  |  |  |  |  | # Options they can pass via hash or hashref. | 
| 142 | 0 |  |  | 0 | 1 |  | sub default_options { | 
| 143 |  |  |  |  |  |  | $self->{default_options}={ | 
| 144 | 0 |  |  |  |  |  | account_name => 0, | 
| 145 |  |  |  |  |  |  | password => 0, | 
| 146 |  |  |  |  |  |  | cache_dir => 0,  # Default set by site_info field method | 
| 147 |  |  |  |  |  |  | cache_file => 0, # Default set by field method below | 
| 148 |  |  |  |  |  |  | auto_login => 0, # Default set by field method below | 
| 149 |  |  |  |  |  |  | human => 0,      # Default set by field method below | 
| 150 |  |  |  |  |  |  | config_file => 0, | 
| 151 |  |  |  |  |  |  | use_defaults => 0 | 
| 152 |  |  |  |  |  |  | }; | 
| 153 |  |  |  |  |  |  |  | 
| 154 | 0 |  |  |  |  |  | return $self->{default_options}; | 
| 155 |  |  |  |  |  |  | } | 
| 156 |  |  |  |  |  |  |  | 
| 157 |  |  |  |  |  |  | =head2 positional_parameters | 
| 158 |  |  |  |  |  |  |  | 
| 159 |  |  |  |  |  |  | You can also allow your users to provide information to the "new" | 
| 160 |  |  |  |  |  |  | method via positional parameters.  If the first argument passed | 
| 161 |  |  |  |  |  |  | to "new" is not a known valid option, positional parameters | 
| 162 |  |  |  |  |  |  | are used instead. | 
| 163 |  |  |  |  |  |  |  | 
| 164 |  |  |  |  |  |  | These default to: | 
| 165 |  |  |  |  |  |  |  | 
| 166 |  |  |  |  |  |  | const positional_parameters => [ 'account_name', 'password' ]; | 
| 167 |  |  |  |  |  |  |  | 
| 168 |  |  |  |  |  |  | You can override this method to provide your own list if you like: | 
| 169 |  |  |  |  |  |  |  | 
| 170 |  |  |  |  |  |  | const positional_parameters => [ 'account_name', 'password', 'shoe_size' ]; | 
| 171 |  |  |  |  |  |  |  | 
| 172 |  |  |  |  |  |  |  | 
| 173 |  |  |  |  |  |  |  | 
| 174 |  |  |  |  |  |  | =cut | 
| 175 |  |  |  |  |  |  |  | 
| 176 |  |  |  |  |  |  | # Options they can pass by position. | 
| 177 |  |  |  |  |  |  | # Just "new( 'joe@bebo.com', 'mypass' )". | 
| 178 |  |  |  |  |  |  | const positional_parameters => [ 'account_name', 'password' ]; | 
| 179 |  |  |  |  |  |  |  | 
| 180 |  |  |  |  |  |  | field 'account_name'; | 
| 181 |  |  |  |  |  |  | field 'password'; | 
| 182 |  |  |  |  |  |  | field cache_file => 'login_cache'; | 
| 183 |  |  |  |  |  |  | field auto_login => 0; | 
| 184 |  |  |  |  |  |  | field human => 1; | 
| 185 |  |  |  |  |  |  | field use_defaults => 0; | 
| 186 |  |  |  |  |  |  |  | 
| 187 |  |  |  |  |  |  | stub 'site_info'; | 
| 188 |  |  |  |  |  |  |  | 
| 189 |  |  |  |  |  |  | =head1 OPTION ACCESSORS | 
| 190 |  |  |  |  |  |  |  | 
| 191 |  |  |  |  |  |  | These methods can be used to set/retreive the respective option's value. | 
| 192 |  |  |  |  |  |  | They're also up top here to document the option, which can be passed | 
| 193 |  |  |  |  |  |  | directly to the "new" method. | 
| 194 |  |  |  |  |  |  |  | 
| 195 |  |  |  |  |  |  | =head2 account_name | 
| 196 |  |  |  |  |  |  |  | 
| 197 |  |  |  |  |  |  | Sets or returns the account name (email address) under which you're logged in. | 
| 198 |  |  |  |  |  |  | Note that the account name is retreived from the user or from your program | 
| 199 |  |  |  |  |  |  | depending on how you called the "new" method. You'll probably only use this | 
| 200 |  |  |  |  |  |  | accessor method to get account_name. | 
| 201 |  |  |  |  |  |  |  | 
| 202 |  |  |  |  |  |  | EXAMPLE | 
| 203 |  |  |  |  |  |  |  | 
| 204 |  |  |  |  |  |  | The following would prompt the user for their login information, then print | 
| 205 |  |  |  |  |  |  | out the account name: | 
| 206 |  |  |  |  |  |  |  | 
| 207 |  |  |  |  |  |  | use WWW::Bebo; | 
| 208 |  |  |  |  |  |  | my $bebo = new WWW::Bebo; | 
| 209 |  |  |  |  |  |  |  | 
| 210 |  |  |  |  |  |  | print $site->account_name; | 
| 211 |  |  |  |  |  |  |  | 
| 212 |  |  |  |  |  |  | $site->account_name( 'other_account@bebo.com' ); | 
| 213 |  |  |  |  |  |  | $site->password( 'other_accounts_password' ); | 
| 214 |  |  |  |  |  |  | $site->site_login; | 
| 215 |  |  |  |  |  |  |  | 
| 216 |  |  |  |  |  |  | WARNING: If you do change account_name, make sure you change password and | 
| 217 |  |  |  |  |  |  | call site_login.  Changing account_name doesn't (currently) log you | 
| 218 |  |  |  |  |  |  | out, nor does it clear "password".  If you change this and don't log in | 
| 219 |  |  |  |  |  |  | under the new account, it'll just have the wrong value, which will probably | 
| 220 |  |  |  |  |  |  | be ignored, but who knows. | 
| 221 |  |  |  |  |  |  |  | 
| 222 |  |  |  |  |  |  | =cut | 
| 223 |  |  |  |  |  |  |  | 
| 224 |  |  |  |  |  |  |  | 
| 225 |  |  |  |  |  |  | =head2 password | 
| 226 |  |  |  |  |  |  |  | 
| 227 |  |  |  |  |  |  | Sets or returns the password you used, or will use, to log in. See the | 
| 228 |  |  |  |  |  |  | warning under "account_name" above - same applies here. | 
| 229 |  |  |  |  |  |  |  | 
| 230 |  |  |  |  |  |  | =cut | 
| 231 |  |  |  |  |  |  |  | 
| 232 |  |  |  |  |  |  |  | 
| 233 |  |  |  |  |  |  | =head2 cache_dir | 
| 234 |  |  |  |  |  |  |  | 
| 235 |  |  |  |  |  |  | WWW::Sitebase::Navigator stores the last account/password used in a | 
| 236 |  |  |  |  |  |  | cache file for convenience if the user's entering it. Other modules | 
| 237 |  |  |  |  |  |  | store other cache data as well. | 
| 238 |  |  |  |  |  |  |  | 
| 239 |  |  |  |  |  |  | cache_dir sets or returns the directory in which we should store cache | 
| 240 |  |  |  |  |  |  | data. Defaults to $self->site_info->{cache_dir}. | 
| 241 |  |  |  |  |  |  |  | 
| 242 |  |  |  |  |  |  | If using this from a CGI script, you will need to provide the | 
| 243 |  |  |  |  |  |  | account and password in the "new" method call, or call "new" with | 
| 244 |  |  |  |  |  |  | "auto_login => 0" so cache_dir will not be used. | 
| 245 |  |  |  |  |  |  |  | 
| 246 |  |  |  |  |  |  | =cut | 
| 247 |  |  |  |  |  |  |  | 
| 248 | 0 |  |  | 0 | 1 |  | sub cache_dir { return catfile( $self->_home_dir, | 
| 249 | 0 |  |  |  |  |  | $self->site_info->{'cache_dir'} ) } | 
| 250 |  |  |  |  |  |  |  | 
| 251 |  |  |  |  |  |  | =head2 cache_file | 
| 252 |  |  |  |  |  |  |  | 
| 253 |  |  |  |  |  |  | Sets or returns the name of the file into which the login | 
| 254 |  |  |  |  |  |  | cache data is stored. Defaults to login_cache. | 
| 255 |  |  |  |  |  |  |  | 
| 256 |  |  |  |  |  |  | If using this from a CGI script, you will need to provide the | 
| 257 |  |  |  |  |  |  | account and password in the "new" method call, so cache_file will | 
| 258 |  |  |  |  |  |  | not be used. | 
| 259 |  |  |  |  |  |  |  | 
| 260 |  |  |  |  |  |  | =cut | 
| 261 |  |  |  |  |  |  |  | 
| 262 |  |  |  |  |  |  |  | 
| 263 |  |  |  |  |  |  | =head2 auto_login | 
| 264 |  |  |  |  |  |  |  | 
| 265 |  |  |  |  |  |  | Really only useful as an option passed to the "new" method when | 
| 266 |  |  |  |  |  |  | creating a new object. | 
| 267 |  |  |  |  |  |  |  | 
| 268 |  |  |  |  |  |  | # Create a new object and prompt the user to log in. | 
| 269 |  |  |  |  |  |  | my $site = new WWW::MySite( auto_login => 1 ); | 
| 270 |  |  |  |  |  |  |  | 
| 271 |  |  |  |  |  |  | =cut | 
| 272 |  |  |  |  |  |  |  | 
| 273 |  |  |  |  |  |  |  | 
| 274 |  |  |  |  |  |  | =head2 human | 
| 275 |  |  |  |  |  |  |  | 
| 276 |  |  |  |  |  |  | When set to a true value (which is the default), adds delays to | 
| 277 |  |  |  |  |  |  | make the module act more like a human.  This is both to offset | 
| 278 |  |  |  |  |  |  | "faux security" measures, and to conserve bandwidth.  If you're | 
| 279 |  |  |  |  |  |  | trying to use multiple accounts to spam users who don't | 
| 280 |  |  |  |  |  |  | want to hear what you have to say, you should turn this off | 
| 281 |  |  |  |  |  |  | because it'll make your spamming go faster. | 
| 282 |  |  |  |  |  |  |  | 
| 283 |  |  |  |  |  |  | =head2 use_defaults | 
| 284 |  |  |  |  |  |  |  | 
| 285 |  |  |  |  |  |  | When set to a true value, cached username and password will be used, and | 
| 286 |  |  |  |  |  |  | the user will only be prompted for a username and password if one or both | 
| 287 |  |  |  |  |  |  | aren't already stored. | 
| 288 |  |  |  |  |  |  |  | 
| 289 |  |  |  |  |  |  | =cut | 
| 290 |  |  |  |  |  |  |  | 
| 291 |  |  |  |  |  |  |  | 
| 292 |  |  |  |  |  |  | =head1 FUNCTIONS | 
| 293 |  |  |  |  |  |  |  | 
| 294 |  |  |  |  |  |  | =head2 new( $account, $password ) | 
| 295 |  |  |  |  |  |  |  | 
| 296 |  |  |  |  |  |  | =head2 new( ) | 
| 297 |  |  |  |  |  |  |  | 
| 298 |  |  |  |  |  |  | If called without the optional account and password, the new method | 
| 299 |  |  |  |  |  |  | looks in a user-specific preferences file in the user's home | 
| 300 |  |  |  |  |  |  | directory for the last-used account and password. It prompts | 
| 301 |  |  |  |  |  |  | for the username and password with which to log in, providing | 
| 302 |  |  |  |  |  |  | the last-used data (from the preferences file) as defaults. | 
| 303 |  |  |  |  |  |  |  | 
| 304 |  |  |  |  |  |  | Once the account and password have been retreived, the new method | 
| 305 |  |  |  |  |  |  | automatically invokes the "site_login" method and returns a new | 
| 306 |  |  |  |  |  |  | object reference. The new object already contains the | 
| 307 |  |  |  |  |  |  | content of the user's "home" page, the user's friend ID, and | 
| 308 |  |  |  |  |  |  | a WWW::Mechanize object used internally as the "browser" that is used | 
| 309 |  |  |  |  |  |  | by all methods in the class. | 
| 310 |  |  |  |  |  |  |  | 
| 311 |  |  |  |  |  |  | If account_name and password are specified, the "new" method will | 
| 312 |  |  |  |  |  |  | set auto_login to 1 and call the "site_login" method.  This just means | 
| 313 |  |  |  |  |  |  | that if you pass an account_name and password when creating the object, | 
| 314 |  |  |  |  |  |  | it'll log you in unless you explicitly state "auto_login => 0". | 
| 315 |  |  |  |  |  |  |  | 
| 316 |  |  |  |  |  |  | WWW::Sitebase::Navigator is a subclass of WWW::Sitebase, which | 
| 317 |  |  |  |  |  |  | basically just means people can call your "new" method in many ways: | 
| 318 |  |  |  |  |  |  |  | 
| 319 |  |  |  |  |  |  | EXAMPLES | 
| 320 |  |  |  |  |  |  | use WWW::YourSiteModule; | 
| 321 |  |  |  |  |  |  |  | 
| 322 |  |  |  |  |  |  | # Just create the object | 
| 323 |  |  |  |  |  |  | my $site = new WWW::YourSiteModule; | 
| 324 |  |  |  |  |  |  |  | 
| 325 |  |  |  |  |  |  | # Prompt for username and password | 
| 326 |  |  |  |  |  |  | my $site = new WWW::YourSiteModule( auto_login => 1 ); | 
| 327 |  |  |  |  |  |  |  | 
| 328 |  |  |  |  |  |  | # Pass just username and password (logs you in) | 
| 329 |  |  |  |  |  |  | my $site = new WWW::YourSiteModule( 'my@email.com', 'mypass' ); | 
| 330 |  |  |  |  |  |  |  | 
| 331 |  |  |  |  |  |  | # Pass options as a hashref | 
| 332 |  |  |  |  |  |  | my $site = new WWW::YourSiteModule( { | 
| 333 |  |  |  |  |  |  | account_name => 'my@email.com', | 
| 334 |  |  |  |  |  |  | password => 'mypass', | 
| 335 |  |  |  |  |  |  | cache_file => 'passcache', | 
| 336 |  |  |  |  |  |  | } ); | 
| 337 |  |  |  |  |  |  |  | 
| 338 |  |  |  |  |  |  | # Pass options as a hash | 
| 339 |  |  |  |  |  |  | my $site = new WWW::YourSiteModule( | 
| 340 |  |  |  |  |  |  | account_name => 'my@email.com', | 
| 341 |  |  |  |  |  |  | password => 'mypass', | 
| 342 |  |  |  |  |  |  | cache_file => 'passcache', | 
| 343 |  |  |  |  |  |  | auto_login => 0,  # Don't log in, just create the object) | 
| 344 |  |  |  |  |  |  | ); | 
| 345 |  |  |  |  |  |  |  | 
| 346 |  |  |  |  |  |  | =cut | 
| 347 |  |  |  |  |  |  |  | 
| 348 |  |  |  |  |  |  | sub new() { | 
| 349 |  |  |  |  |  |  | # Call the Base new method (it's ok to feel special about it). | 
| 350 | 0 |  |  | 0 | 1 |  | my $self = super; | 
| 351 |  |  |  |  |  |  |  | 
| 352 |  |  |  |  |  |  | # Log in if requested | 
| 353 | 0 | 0 | 0 |  |  |  | $self->auto_login(1) if ( $self->account_name && $self->password ); | 
| 354 | 0 | 0 |  |  |  |  | if ( $self->auto_login ) { | 
| 355 |  |  |  |  |  |  |  | 
| 356 |  |  |  |  |  |  | # Prompt for username/password if we don't have them yet. | 
| 357 |  |  |  |  |  |  | # (should this be moved to site_login?) | 
| 358 | 0 | 0 |  |  |  |  | $self->_get_acct unless $self->account_name; | 
| 359 |  |  |  |  |  |  |  | 
| 360 | 0 |  |  |  |  |  | $self->site_login; | 
| 361 |  |  |  |  |  |  |  | 
| 362 |  |  |  |  |  |  | } else { | 
| 363 |  |  |  |  |  |  |  | 
| 364 | 0 |  |  |  |  |  | $self->logout; # Why?  Resets variables and gets Mech object. | 
| 365 |  |  |  |  |  |  |  | 
| 366 |  |  |  |  |  |  | } | 
| 367 |  |  |  |  |  |  |  | 
| 368 | 0 |  |  |  |  |  | return $self; | 
| 369 |  |  |  |  |  |  | } | 
| 370 |  |  |  |  |  |  |  | 
| 371 |  |  |  |  |  |  | =head2 site_login | 
| 372 |  |  |  |  |  |  |  | 
| 373 |  |  |  |  |  |  | Logs into the account identified by the "account_name" and | 
| 374 |  |  |  |  |  |  | "password" options. | 
| 375 |  |  |  |  |  |  |  | 
| 376 |  |  |  |  |  |  | If you don't call the new method with "login => 1", you'll need to | 
| 377 |  |  |  |  |  |  | call this method if you want to log in. | 
| 378 |  |  |  |  |  |  |  | 
| 379 |  |  |  |  |  |  | If the login gets a "you must be logged-in" page when you first try to | 
| 380 |  |  |  |  |  |  | log in, $site->error will be set to an error message that says to | 
| 381 |  |  |  |  |  |  | check the username and password. | 
| 382 |  |  |  |  |  |  |  | 
| 383 |  |  |  |  |  |  | Once login is successful for a given username/password combination, | 
| 384 |  |  |  |  |  |  | the object "remembers" that the username/password | 
| 385 |  |  |  |  |  |  | is valid, and if it encounters a "you must be logged-in" page, it will | 
| 386 |  |  |  |  |  |  | try up to 20 times to re-login. | 
| 387 |  |  |  |  |  |  |  | 
| 388 |  |  |  |  |  |  | =cut | 
| 389 |  |  |  |  |  |  |  | 
| 390 | 0 |  |  | 0 | 1 |  | sub site_login { | 
| 391 |  |  |  |  |  |  |  | 
| 392 | 0 |  |  |  |  |  | my $verify_re; | 
| 393 | 0 | 0 |  |  |  |  | if ( defined $self->site_info->{'login_verify_re'} ) { | 
| 394 | 0 |  |  |  |  |  | $verify_re = $self->site_info->{'login_verify_re'} | 
| 395 |  |  |  |  |  |  | }; | 
| 396 |  |  |  |  |  |  |  | 
| 397 |  |  |  |  |  |  | # Reset everything (oddly, this also happens to create a new browser | 
| 398 |  |  |  |  |  |  | # object). | 
| 399 | 0 |  |  |  |  |  | $self->logout; | 
| 400 |  |  |  |  |  |  |  | 
| 401 | 0 | 0 |  |  |  |  | croak "site_login called but account_name isn't set" unless | 
| 402 |  |  |  |  |  |  | ( $self->account_name ); | 
| 403 | 0 | 0 |  |  |  |  | croak "site_login called but password isn't set" unless ( $self->password ); | 
| 404 |  |  |  |  |  |  |  | 
| 405 |  |  |  |  |  |  | # Now log in | 
| 406 | 0 |  |  |  |  |  | $self->_try_login; | 
| 407 | 0 | 0 |  |  |  |  | return undef if $self->error; | 
| 408 |  |  |  |  |  |  |  | 
| 409 |  |  |  |  |  |  | # Load the home page. | 
| 410 |  |  |  |  |  |  | #     $self->_go_home; | 
| 411 |  |  |  |  |  |  |  | 
| 412 |  |  |  |  |  |  | # Verify we're logged in | 
| 413 | 0 | 0 | 0 |  |  |  | if ( ( ! $verify_re ) || | 
| 414 |  |  |  |  |  |  | ( $self->current_page->decoded_content =~ /$verify_re/si ) | 
| 415 |  |  |  |  |  |  | ) { | 
| 416 | 0 |  |  |  |  |  | $self->logged_in( 1 ); | 
| 417 |  |  |  |  |  |  | } else { | 
| 418 | 0 |  |  |  |  |  | $self->logged_in( 0 ); | 
| 419 | 0 | 0 |  |  |  |  | unless ( $self->error ) { | 
| 420 | 0 |  |  |  |  |  | $self->error( "Login Failed. Couldn't verify load of home page." ) | 
| 421 |  |  |  |  |  |  | } | 
| 422 | 0 |  |  |  |  |  | return undef; | 
| 423 |  |  |  |  |  |  | } | 
| 424 |  |  |  |  |  |  |  | 
| 425 | 0 |  |  |  |  |  | return 1; | 
| 426 |  |  |  |  |  |  |  | 
| 427 |  |  |  |  |  |  | } | 
| 428 |  |  |  |  |  |  |  | 
| 429 |  |  |  |  |  |  | # _try_login | 
| 430 |  |  |  |  |  |  | # You call this as $self->_try_login.  Attempts to log in using | 
| 431 |  |  |  |  |  |  | # the set account_name and password. It gets and submits the login form, | 
| 432 |  |  |  |  |  |  | # then checks for a valid submission and for a "you must be logged-in" | 
| 433 |  |  |  |  |  |  | # page. | 
| 434 |  |  |  |  |  |  | # If called with a number as an argument, tries that many times to | 
| 435 |  |  |  |  |  |  | # submit the form.  It calls itself recursively. | 
| 436 | 0 |  |  | 0 |  |  | sub _try_login { | 
| 437 |  |  |  |  |  |  |  | 
| 438 |  |  |  |  |  |  | # Set the recursive tries counter. | 
| 439 | 0 |  |  |  |  |  | my ( $tries_left ) = @_; | 
| 440 | 0 | 0 |  |  |  |  | if ( $tries_left ) { $tries_left--;  return if ( $tries_left ) < 1; } | 
|  | 0 | 0 |  |  |  |  |  | 
|  | 0 |  |  |  |  |  |  | 
| 441 | 0 | 0 |  |  |  |  | $tries_left = 20 unless defined $tries_left; | 
| 442 |  |  |  |  |  |  |  | 
| 443 |  |  |  |  |  |  | # Default the login form to form#1 for backward compatibility. | 
| 444 |  |  |  |  |  |  | $self->site_info->{'login_form_no'} = 1 | 
| 445 | 0 | 0 | 0 |  |  |  | unless ( $self->site_info->{'login_form_no'} || $self->site_info->{'login_form_name'} ); | 
| 446 |  |  |  |  |  |  |  | 
| 447 |  |  |  |  |  |  | # Submit the login form | 
| 448 | 0 |  |  |  |  |  | my $submitted = $self->_submit_login; | 
| 449 |  |  |  |  |  |  |  | 
| 450 |  |  |  |  |  |  | # Check for success | 
| 451 | 0 | 0 |  |  |  |  | if ( $submitted ) { | 
| 452 |  |  |  |  |  |  |  | 
| 453 |  |  |  |  |  |  | # Check for invalid login page, which means we either have | 
| 454 |  |  |  |  |  |  | # an invalid login/password, or bebo is messing up again. | 
| 455 | 0 | 0 |  |  |  |  | unless ( $self->_check_login ) { | 
| 456 |  |  |  |  |  |  | # Fail unless we already know this account/password is good, in | 
| 457 |  |  |  |  |  |  | # which case we'll just beat the door down until we can get in | 
| 458 |  |  |  |  |  |  | # or the maximum number of attempts has been reached. | 
| 459 | 0 | 0 |  |  |  |  | if ( $self->_account_verified ) { | 
| 460 | 0 |  |  |  |  |  | $self->_try_login( $tries_left ); | 
| 461 |  |  |  |  |  |  | } else { | 
| 462 | 0 |  |  |  |  |  | $self->error( "Login Failed.  Got 'You Must Be Logged-In' page ". | 
| 463 |  |  |  |  |  |  | "when logging in.\nCheck username and password." ); | 
| 464 | 0 |  |  |  |  |  | return undef; | 
| 465 |  |  |  |  |  |  | } | 
| 466 |  |  |  |  |  |  | } | 
| 467 |  |  |  |  |  |  | } else { | 
| 468 | 0 |  |  |  |  |  | return undef; | 
| 469 |  |  |  |  |  |  | } | 
| 470 |  |  |  |  |  |  |  | 
| 471 | 0 |  |  |  |  |  | return 1; | 
| 472 |  |  |  |  |  |  |  | 
| 473 |  |  |  |  |  |  | } | 
| 474 |  |  |  |  |  |  |  | 
| 475 |  |  |  |  |  |  | =head2 _submit_login | 
| 476 |  |  |  |  |  |  |  | 
| 477 |  |  |  |  |  |  | This method just calls submit_form with the values specified in site_info. | 
| 478 |  |  |  |  |  |  | It's been separated out just in case you have a sticky login form and you | 
| 479 |  |  |  |  |  |  | want to override this method to do something fancy.  The other option was to | 
| 480 |  |  |  |  |  |  | give a lot more options in site_info, but to really give the amount of control | 
| 481 |  |  |  |  |  |  | you might need, it just makes more sense to set up site_info for the usual cases, | 
| 482 |  |  |  |  |  |  | and override this method if you need to get fancy. | 
| 483 |  |  |  |  |  |  |  | 
| 484 |  |  |  |  |  |  | You must return 1 for success, 0 for failure.  All you really need to do is | 
| 485 |  |  |  |  |  |  | this: | 
| 486 |  |  |  |  |  |  |  | 
| 487 |  |  |  |  |  |  | # Submit the login form | 
| 488 |  |  |  |  |  |  | my $submitted = $self->submit_form( | 
| 489 |  |  |  |  |  |  | page => $self->site_info->{'home_page'}, | 
| 490 |  |  |  |  |  |  | form_name => $self->site_info->{'login_form_name'}, | 
| 491 |  |  |  |  |  |  | form_no => $self->site_info->{'login_form_no'}, | 
| 492 |  |  |  |  |  |  | fields_ref => { | 
| 493 |  |  |  |  |  |  | $self->site_info->{'account_field'} => $self->account_name, | 
| 494 |  |  |  |  |  |  | $self->site_info->{'password_field'} => $self->password | 
| 495 |  |  |  |  |  |  | } | 
| 496 |  |  |  |  |  |  | ); | 
| 497 |  |  |  |  |  |  |  | 
| 498 |  |  |  |  |  |  | return $submitted; | 
| 499 |  |  |  |  |  |  |  | 
| 500 |  |  |  |  |  |  | And fill in your special values instead.  Again, only do this if your login | 
| 501 |  |  |  |  |  |  | doesn't work with the stuff you set up in site_info. | 
| 502 |  |  |  |  |  |  |  | 
| 503 |  |  |  |  |  |  | =cut | 
| 504 |  |  |  |  |  |  |  | 
| 505 | 0 |  |  | 0 |  |  | sub _submit_login { | 
| 506 |  |  |  |  |  |  |  | 
| 507 |  |  |  |  |  |  | return $self->submit_form( | 
| 508 |  |  |  |  |  |  | page => $self->site_info->{'home_page'}, | 
| 509 |  |  |  |  |  |  | form_name => $self->site_info->{'login_form_name'}, | 
| 510 |  |  |  |  |  |  | form_no => $self->site_info->{'login_form_no'}, | 
| 511 |  |  |  |  |  |  | fields_ref => { | 
| 512 |  |  |  |  |  |  | $self->site_info->{'account_field'} => $self->account_name, | 
| 513 | 0 |  |  |  |  |  | $self->site_info->{'password_field'} => $self->password | 
| 514 |  |  |  |  |  |  | } | 
| 515 |  |  |  |  |  |  | ); | 
| 516 |  |  |  |  |  |  |  | 
| 517 |  |  |  |  |  |  | } | 
| 518 |  |  |  |  |  |  |  | 
| 519 |  |  |  |  |  |  | =head2 _check_login | 
| 520 |  |  |  |  |  |  |  | 
| 521 |  |  |  |  |  |  | Checks for "You must be logged in to do that".  If found, tries to log | 
| 522 |  |  |  |  |  |  | in again and returns 0, otherwise returns 1. | 
| 523 |  |  |  |  |  |  |  | 
| 524 |  |  |  |  |  |  | =cut | 
| 525 |  |  |  |  |  |  |  | 
| 526 | 0 |  |  | 0 |  |  | sub _check_login { | 
| 527 | 0 |  |  |  |  |  | my ( $res ) = @_; | 
| 528 | 0 |  |  |  |  |  | my $re = ""; | 
| 529 |  |  |  |  |  |  |  | 
| 530 |  |  |  |  |  |  | # Check the current page by default | 
| 531 | 0 | 0 |  |  |  |  | unless ( $res ) { $res = $self->current_page } | 
|  | 0 |  |  |  |  |  |  | 
| 532 |  |  |  |  |  |  |  | 
| 533 |  |  |  |  |  |  | # Check for the "proper" error response, or just look for the | 
| 534 |  |  |  |  |  |  | # error message on the page. | 
| 535 | 0 |  |  |  |  |  | $re = $self->site_info->{'not_logged_in_re'}; | 
| 536 | 0 | 0 | 0 |  |  |  | if ( ( $res->is_error == 403 ) || ( $res->decoded_content =~ /$re/is ) ) { | 
| 537 | 0 | 0 |  |  |  |  | if ( $res->is_error ) { | 
| 538 | 0 |  |  |  |  |  | warn "Error: " . $res->is_error . "\n" | 
| 539 |  |  |  |  |  |  | } else { | 
| 540 | 0 |  |  |  |  |  | warn "Got \"not logged in\" page\n"; | 
| 541 |  |  |  |  |  |  | } | 
| 542 |  |  |  |  |  |  | # If we already logged in, try to log us back in. | 
| 543 | 0 | 0 |  |  |  |  | if ( $self->logged_in ) { $self->site_login } | 
|  | 0 |  |  |  |  |  |  | 
| 544 |  |  |  |  |  |  | # Return 0 so they'll try again. | 
| 545 | 0 |  |  |  |  |  | return 0; | 
| 546 |  |  |  |  |  |  | } else { | 
| 547 | 0 |  |  |  |  |  | return 1; | 
| 548 |  |  |  |  |  |  | } | 
| 549 |  |  |  |  |  |  |  | 
| 550 |  |  |  |  |  |  | } | 
| 551 |  |  |  |  |  |  |  | 
| 552 |  |  |  |  |  |  | # _account_verified | 
| 553 |  |  |  |  |  |  | # Returns true if we've verified that the current account and password | 
| 554 |  |  |  |  |  |  | # are valid (by successfully logging in with them) | 
| 555 | 0 |  |  | 0 |  |  | sub _account_verified { | 
| 556 |  |  |  |  |  |  |  | 
| 557 |  |  |  |  |  |  | ( ( $self->{_account_verified}->{ $self->account_name } ) && | 
| 558 | 0 | 0 |  |  |  |  | ( $self->password = $self->{_account_verified}->{ $self->account_name } ) | 
| 559 |  |  |  |  |  |  | ) | 
| 560 |  |  |  |  |  |  |  | 
| 561 |  |  |  |  |  |  | } | 
| 562 |  |  |  |  |  |  |  | 
| 563 |  |  |  |  |  |  | # _init_account | 
| 564 |  |  |  |  |  |  | # Initialize basic account/login-specific settings after login | 
| 565 | 0 |  |  | 0 |  |  | sub _init_account { | 
| 566 |  |  |  |  |  |  |  | 
| 567 |  |  |  |  |  |  | # Get our friend ID from our profile page (which happens to | 
| 568 |  |  |  |  |  |  | # be the page we go to after logging in). | 
| 569 | 0 |  |  |  |  |  | $self->_get_friend_id( $self->current_page ); | 
| 570 |  |  |  |  |  |  |  | 
| 571 |  |  |  |  |  |  | # If for some reason we couldn't set this, fail login. | 
| 572 | 0 | 0 |  |  |  |  | unless ( $self->my_friend_id ) { $self->logged_in(0) ; return } | 
|  | 0 |  |  |  |  |  |  | 
|  | 0 |  |  |  |  |  |  | 
| 573 |  |  |  |  |  |  |  | 
| 574 |  |  |  |  |  |  | # Set the user_name and friend_count fields. | 
| 575 | 0 |  |  |  |  |  | $self->user_name( $self->current_page ); | 
| 576 | 0 |  |  |  |  |  | $self->friend_count( $self->current_page ); | 
| 577 |  |  |  |  |  |  |  | 
| 578 |  |  |  |  |  |  | # Cache whether or not we're a band. | 
| 579 | 0 |  |  |  |  |  | $self->is_band; | 
| 580 |  |  |  |  |  |  |  | 
| 581 |  |  |  |  |  |  | # Note that we've verified this account/password | 
| 582 | 0 |  |  |  |  |  | $self->{_account_verified}->{ $self->account_name } = $self->password; | 
| 583 |  |  |  |  |  |  |  | 
| 584 |  |  |  |  |  |  | } | 
| 585 |  |  |  |  |  |  |  | 
| 586 | 0 |  |  | 0 |  |  | sub _new_mech { | 
| 587 |  |  |  |  |  |  |  | 
| 588 |  |  |  |  |  |  | # Set up our web browser (WWW::Mechanize object) | 
| 589 | 0 |  |  |  |  |  | $self->mech( new WWW::Mechanize( | 
| 590 |  |  |  |  |  |  | onerror => undef, | 
| 591 |  |  |  |  |  |  | # We'll say we're Safari running on MacOS 10.9.1 | 
| 592 |  |  |  |  |  |  | agent => 'Mozilla/5.0 (Macintosh; Intel Mac OS X 10_9_1)' | 
| 593 |  |  |  |  |  |  | . ' AppleWebKit/537.73.11 (KHTML, like Gecko) Version/7.0.1' | 
| 594 |  |  |  |  |  |  | . ' Safari/537.73.11', | 
| 595 |  |  |  |  |  |  | stack_depth => 1, | 
| 596 |  |  |  |  |  |  | quiet => 1, | 
| 597 |  |  |  |  |  |  | ) ); | 
| 598 |  |  |  |  |  |  |  | 
| 599 |  |  |  |  |  |  | # We need to follow redirects for POST too. | 
| 600 | 0 |  |  |  |  |  | push @{ $self->mech->requests_redirectable }, 'POST'; | 
|  | 0 |  |  |  |  |  |  | 
| 601 |  |  |  |  |  |  |  | 
| 602 |  |  |  |  |  |  | } | 
| 603 |  |  |  |  |  |  |  | 
| 604 |  |  |  |  |  |  | #--------------------------------------------------------------------- | 
| 605 |  |  |  |  |  |  | # _get_acct() | 
| 606 |  |  |  |  |  |  | # Get and store the login and password. We check the user's preference | 
| 607 |  |  |  |  |  |  | # file for defaults, then prompt them. | 
| 608 |  |  |  |  |  |  |  | 
| 609 | 0 |  |  | 0 |  |  | sub _get_acct { | 
| 610 |  |  |  |  |  |  |  | 
| 611 |  |  |  |  |  |  | # Initialize | 
| 612 | 0 |  |  |  |  |  | my $prefs = {}; | 
| 613 | 0 |  |  |  |  |  | my $ref = ""; | 
| 614 | 0 |  |  |  |  |  | my ( $pref, $value, $res ); | 
| 615 | 0 |  |  |  |  |  | my $cache_filepath = catfile( $self->cache_dir, $self->cache_file); | 
| 616 |  |  |  |  |  |  |  | 
| 617 |  |  |  |  |  |  | # Read what we got last time. | 
| 618 | 0 | 0 |  |  |  |  | if ( open ( PREFS, "< ", $cache_filepath ) ) { | 
| 619 | 0 |  |  |  |  |  | while () { | 
| 620 | 0 |  |  |  |  |  | chomp; | 
| 621 | 0 |  |  |  |  |  | ( $pref, $value ) = split( ":" ); | 
| 622 | 0 |  |  |  |  |  | $prefs->{"$pref"} = $value; | 
| 623 |  |  |  |  |  |  | } | 
| 624 |  |  |  |  |  |  |  | 
| 625 | 0 |  |  |  |  |  | close PREFS; | 
| 626 |  |  |  |  |  |  | } | 
| 627 |  |  |  |  |  |  |  | 
| 628 |  |  |  |  |  |  | # If we have a username and password, and they asked us to use the | 
| 629 |  |  |  |  |  |  | # cached defaults, then skip the login prompts.  Otherwise, prompt | 
| 630 |  |  |  |  |  |  | # the user for login info. | 
| 631 | 0 | 0 | 0 |  |  |  | unless ( $self->use_defaults && $prefs->{'email'} && $prefs->{'password'} ) { | 
|  |  |  | 0 |  |  |  |  | 
| 632 | 0 |  |  |  |  |  | $prefs = $self->_prompt_for_login( $prefs ); | 
| 633 |  |  |  |  |  |  | } | 
| 634 |  |  |  |  |  |  |  | 
| 635 |  |  |  |  |  |  | # Store the account info. | 
| 636 | 0 |  |  |  |  |  | $self->{account_name}=$prefs->{"email"}; | 
| 637 | 0 |  |  |  |  |  | $self->{password}=$prefs->{"password"}; | 
| 638 |  |  |  |  |  |  | } | 
| 639 |  |  |  |  |  |  |  | 
| 640 |  |  |  |  |  |  | # _prompt_for_login( { email => $email, password => $password } ) | 
| 641 |  |  |  |  |  |  | # | 
| 642 |  |  |  |  |  |  | # Given an optional email and password, prompt the user, displaying the | 
| 643 |  |  |  |  |  |  | # existing email and password as defaults (well, passwords are displayed as | 
| 644 |  |  |  |  |  |  | # "*****").  Returns the email and password entered, or defaulted to, | 
| 645 |  |  |  |  |  |  | # by the user. | 
| 646 |  |  |  |  |  |  | # | 
| 647 | 0 |  |  | 0 |  |  | sub _prompt_for_login { | 
| 648 | 0 |  |  |  |  |  | my ( $prefs ) = @_; | 
| 649 |  |  |  |  |  |  |  | 
| 650 |  |  |  |  |  |  | # Prompt them for current values | 
| 651 | 0 | 0 |  |  |  |  | unless ( defined $prefs->{"email"} ) { $prefs->{"email"} = "" } | 
|  | 0 |  |  |  |  |  |  | 
| 652 | 0 |  |  |  |  |  | print "Email [" . $prefs->{"email"} . "]: "; | 
| 653 | 0 |  |  |  |  |  | my $res = ReadLine 0; chomp $res; | 
|  | 0 |  |  |  |  |  |  | 
| 654 | 0 | 0 |  |  |  |  | if ( $res ) { | 
| 655 | 0 |  |  |  |  |  | $prefs->{"email"} = $res; | 
| 656 |  |  |  |  |  |  | } | 
| 657 |  |  |  |  |  |  |  | 
| 658 | 0 | 0 |  |  |  |  | unless ( defined $prefs->{"password"} ) { $prefs->{"password"} = "" } | 
|  | 0 |  |  |  |  |  |  | 
| 659 | 0 | 0 |  |  |  |  | my $password_indicator = $prefs->{'password'} ? '*****' : ''; | 
| 660 | 0 |  |  |  |  |  | print "Password [". $password_indicator . "]: "; | 
| 661 | 0 |  |  |  |  |  | ReadMode 'noecho'; # From Term::ReadKey.  Make password not echo. | 
| 662 | 0 |  |  |  |  |  | $res = ReadLine 0; | 
| 663 | 0 |  |  |  |  |  | chomp $res; | 
| 664 | 0 |  |  |  |  |  | ReadMode 'normal'; | 
| 665 | 0 |  |  |  |  |  | print "\n"; # Because ReadLine won't output a new line when they hit return | 
| 666 | 0 | 0 |  |  |  |  | if ( $res ) { | 
| 667 | 0 |  |  |  |  |  | $prefs->{"password"} = $res; | 
| 668 |  |  |  |  |  |  | } | 
| 669 |  |  |  |  |  |  |  | 
| 670 |  |  |  |  |  |  | # Make the cache directory if it doesn't exist. | 
| 671 | 0 |  |  |  |  |  | $self->make_cache_dir; | 
| 672 |  |  |  |  |  |  |  | 
| 673 |  |  |  |  |  |  | # Store the new values.  We clobber the file, set it r/w by the user, | 
| 674 |  |  |  |  |  |  | # *then* write. | 
| 675 | 0 |  |  |  |  |  | my $cache_filepath = catfile( $self->cache_dir, $self->cache_file); | 
| 676 | 0 | 0 |  |  |  |  | open ( PREFS, ">", $cache_filepath ) or croak $!; | 
| 677 | 0 |  |  |  |  |  | chmod 0600, $cache_filepath; | 
| 678 |  |  |  |  |  |  | print PREFS "email:" . $prefs->{"email"} . "\n" . | 
| 679 | 0 |  |  |  |  |  | "password:" . $prefs->{"password"} . "\n"; | 
| 680 | 0 | 0 |  |  |  |  | close PREFS || croak "Error closing file when writing username/password: $!"; | 
| 681 |  |  |  |  |  |  |  | 
| 682 | 0 |  |  |  |  |  | return $prefs; | 
| 683 |  |  |  |  |  |  | } | 
| 684 |  |  |  |  |  |  |  | 
| 685 |  |  |  |  |  |  | =head2 logout | 
| 686 |  |  |  |  |  |  |  | 
| 687 |  |  |  |  |  |  | Clears the current web browsing object and resets any login-specific | 
| 688 |  |  |  |  |  |  | internal values.  Currently this drops and creates a new WWW::Mechanize | 
| 689 |  |  |  |  |  |  | object.  This may change in the future to actually clicking "logout" | 
| 690 |  |  |  |  |  |  | or something. | 
| 691 |  |  |  |  |  |  |  | 
| 692 |  |  |  |  |  |  | =cut | 
| 693 |  |  |  |  |  |  |  | 
| 694 | 0 |  |  | 0 | 1 |  | sub logout { | 
| 695 |  |  |  |  |  |  |  | 
| 696 |  |  |  |  |  |  | # If you change this to just log out instead of making a new Mech | 
| 697 |  |  |  |  |  |  | # object, be sure you change site_login too. | 
| 698 | 0 |  |  |  |  |  | $self->_new_mech; | 
| 699 |  |  |  |  |  |  |  | 
| 700 |  |  |  |  |  |  | # Clear anything login-specific | 
| 701 | 0 |  |  |  |  |  | $self->logged_in(0); | 
| 702 | 0 |  |  |  |  |  | $self->error(0); | 
| 703 |  |  |  |  |  |  |  | 
| 704 |  |  |  |  |  |  | # Do NOT clear options that are set by the user! | 
| 705 |  |  |  |  |  |  | #   $self->{account_name} = undef; | 
| 706 |  |  |  |  |  |  | #   $self->{password} = undef; | 
| 707 |  |  |  |  |  |  |  | 
| 708 |  |  |  |  |  |  | } | 
| 709 |  |  |  |  |  |  |  | 
| 710 |  |  |  |  |  |  | #--------------------------------------------------------------------- | 
| 711 |  |  |  |  |  |  | # Value return methods | 
| 712 |  |  |  |  |  |  | # These methods return internal data that is of use to outsiders | 
| 713 |  |  |  |  |  |  |  | 
| 714 | 0 |  |  | 0 |  |  | sub ____CHECK_STATUS____ {} | 
| 715 |  |  |  |  |  |  |  | 
| 716 |  |  |  |  |  |  | =head1 CHECK STATUS | 
| 717 |  |  |  |  |  |  |  | 
| 718 |  |  |  |  |  |  | =head2 logged_in | 
| 719 |  |  |  |  |  |  |  | 
| 720 |  |  |  |  |  |  | Returns true if login was successful. When you call the new method | 
| 721 |  |  |  |  |  |  | of WWW::Sitebase::Navigator, the class logs in using the username and password | 
| 722 |  |  |  |  |  |  | you provided (or that it prompted for).  It then retreives your "home" | 
| 723 |  |  |  |  |  |  | page (the one you see when you click the "Home" button that's set up in your | 
| 724 |  |  |  |  |  |  | site_info field), and checks it against an RE.  If the page matches the RE, | 
| 725 |  |  |  |  |  |  | logged_in is set to a true value. Otherwise it's set to a false value. | 
| 726 |  |  |  |  |  |  |  | 
| 727 |  |  |  |  |  |  | Notes: | 
| 728 |  |  |  |  |  |  | - This method is only set on login. If you're logged out somehow, | 
| 729 |  |  |  |  |  |  | this method won't tell you that (yet - I may add that later). | 
| 730 |  |  |  |  |  |  | - The internal login method calls this method to set the value. | 
| 731 |  |  |  |  |  |  | You can (currently) call logged_in with a value, and it'll set | 
| 732 |  |  |  |  |  |  | it, but that would be stupid, and it might not work later | 
| 733 |  |  |  |  |  |  | anyway, so don't. | 
| 734 |  |  |  |  |  |  |  | 
| 735 |  |  |  |  |  |  | Examples, pretending we have a subclass named WWW::Bebo to navigate a site | 
| 736 |  |  |  |  |  |  | named bebo.com: | 
| 737 |  |  |  |  |  |  |  | 
| 738 |  |  |  |  |  |  | my $bebo = new WWW::Bebo; | 
| 739 |  |  |  |  |  |  | unless ( $site->logged_in ) { | 
| 740 |  |  |  |  |  |  | die "Login failed\n"; | 
| 741 |  |  |  |  |  |  | } | 
| 742 |  |  |  |  |  |  |  | 
| 743 |  |  |  |  |  |  | # This will log you in, looping forever until it succeeds. | 
| 744 |  |  |  |  |  |  | my $bebo; | 
| 745 |  |  |  |  |  |  |  | 
| 746 |  |  |  |  |  |  | do { | 
| 747 |  |  |  |  |  |  | $bebo = new WWW::Bebo( $username, $password ); | 
| 748 |  |  |  |  |  |  | } until ( $site->logged_in ); | 
| 749 |  |  |  |  |  |  |  | 
| 750 |  |  |  |  |  |  | =cut | 
| 751 |  |  |  |  |  |  |  | 
| 752 |  |  |  |  |  |  | field logged_in => 0; | 
| 753 |  |  |  |  |  |  |  | 
| 754 |  |  |  |  |  |  | =head2 error | 
| 755 |  |  |  |  |  |  |  | 
| 756 |  |  |  |  |  |  | This value is set by some methods to return an error message. | 
| 757 |  |  |  |  |  |  | If there's no error, it returns a false value, so you can do this: | 
| 758 |  |  |  |  |  |  |  | 
| 759 |  |  |  |  |  |  | $site->get_profile( 12345 ); | 
| 760 |  |  |  |  |  |  | if ( $site->error ) { | 
| 761 |  |  |  |  |  |  | warn $site->error . "\n"; | 
| 762 |  |  |  |  |  |  | } else { | 
| 763 |  |  |  |  |  |  | # Do stuff | 
| 764 |  |  |  |  |  |  | } | 
| 765 |  |  |  |  |  |  |  | 
| 766 |  |  |  |  |  |  | =cut | 
| 767 |  |  |  |  |  |  |  | 
| 768 |  |  |  |  |  |  | field 'error' => 0; | 
| 769 |  |  |  |  |  |  |  | 
| 770 |  |  |  |  |  |  | =head2 current_page | 
| 771 |  |  |  |  |  |  |  | 
| 772 |  |  |  |  |  |  | Returns a reference to an HTTP::Response object that contains the last page | 
| 773 |  |  |  |  |  |  | retreived by the WWW::Sitebase::Navigator object. All methods (i.e. get_page, post_comment, | 
| 774 |  |  |  |  |  |  | get_profile, etc) set this value. | 
| 775 |  |  |  |  |  |  |  | 
| 776 |  |  |  |  |  |  | EXAMPLE | 
| 777 |  |  |  |  |  |  |  | 
| 778 |  |  |  |  |  |  | The following will print the content of the user's profile page: | 
| 779 |  |  |  |  |  |  |  | 
| 780 |  |  |  |  |  |  | use WWW::Bebo; | 
| 781 |  |  |  |  |  |  | my $bebo = new WWW::Bebo; | 
| 782 |  |  |  |  |  |  |  | 
| 783 |  |  |  |  |  |  | print $site->current_page->decoded_content; | 
| 784 |  |  |  |  |  |  |  | 
| 785 |  |  |  |  |  |  | =cut | 
| 786 |  |  |  |  |  |  |  | 
| 787 | 0 |  |  | 0 | 1 |  | sub current_page { | 
| 788 |  |  |  |  |  |  |  | 
| 789 | 0 |  |  |  |  |  | return $self->{current_page}; | 
| 790 |  |  |  |  |  |  |  | 
| 791 |  |  |  |  |  |  | } | 
| 792 |  |  |  |  |  |  |  | 
| 793 |  |  |  |  |  |  | =head2 mech | 
| 794 |  |  |  |  |  |  |  | 
| 795 |  |  |  |  |  |  | The internal WWW::Mechanize object.  Use at your own risk: I don't | 
| 796 |  |  |  |  |  |  | promose this method will stay here or work the same in the future. | 
| 797 |  |  |  |  |  |  | The internal methods used to access sites are subject to change at | 
| 798 |  |  |  |  |  |  | any time, including using something different than WWW::Mechanize. | 
| 799 |  |  |  |  |  |  |  | 
| 800 |  |  |  |  |  |  | =cut | 
| 801 |  |  |  |  |  |  |  | 
| 802 |  |  |  |  |  |  | field 'mech'; | 
| 803 |  |  |  |  |  |  |  | 
| 804 |  |  |  |  |  |  | =head2 get_page( $url, [ %options ] ) | 
| 805 |  |  |  |  |  |  |  | 
| 806 |  |  |  |  |  |  | get_page returns a referece to a HTTP::Response object that contains | 
| 807 |  |  |  |  |  |  | the web page specified by $url. | 
| 808 |  |  |  |  |  |  |  | 
| 809 |  |  |  |  |  |  | get_page will try up to 20 times until it gets the page, with a 2-second | 
| 810 |  |  |  |  |  |  | delay between attempts. It checks for invalid HTTP response codes, | 
| 811 |  |  |  |  |  |  | and error pages as defined in site_info->{error_regexps}. | 
| 812 |  |  |  |  |  |  |  | 
| 813 |  |  |  |  |  |  | Options can be: | 
| 814 |  |  |  |  |  |  |  | 
| 815 |  |  |  |  |  |  | re => $regular_expression | 
| 816 |  |  |  |  |  |  | follow => 1 | 
| 817 |  |  |  |  |  |  |  | 
| 818 |  |  |  |  |  |  | "re" Is a regular expression.  If provided, get_page | 
| 819 |  |  |  |  |  |  | will consider the page an error unless the page content matches | 
| 820 |  |  |  |  |  |  | the regexp. This is designed to get past network problems and such. | 
| 821 |  |  |  |  |  |  |  | 
| 822 |  |  |  |  |  |  | If "follow" is set, a "Referer" header will be added, simulating | 
| 823 |  |  |  |  |  |  | clicking on a link on the current page to get to the URL provided. | 
| 824 |  |  |  |  |  |  |  | 
| 825 |  |  |  |  |  |  | EXAMPLE | 
| 826 |  |  |  |  |  |  |  | 
| 827 |  |  |  |  |  |  | # The following displays the HTML source of MySpace.com's home | 
| 828 |  |  |  |  |  |  | # page, verifying that there is evidence of a login form on the | 
| 829 |  |  |  |  |  |  | # retreived page. | 
| 830 |  |  |  |  |  |  | my $res=get_page( "http://www.myspace.com/", re => 'E-Mail:.*?Password:' ); | 
| 831 |  |  |  |  |  |  |  | 
| 832 |  |  |  |  |  |  | print $res->decoded_content; | 
| 833 |  |  |  |  |  |  |  | 
| 834 |  |  |  |  |  |  | =cut | 
| 835 |  |  |  |  |  |  |  | 
| 836 | 0 |  |  | 0 | 1 |  | sub get_page { | 
| 837 |  |  |  |  |  |  |  | 
| 838 | 0 |  |  |  |  |  | my ( $url, %options ) = @_; | 
| 839 |  |  |  |  |  |  |  | 
| 840 |  |  |  |  |  |  | # Reset error | 
| 841 | 0 |  |  |  |  |  | $self->error( 0 ); | 
| 842 |  |  |  |  |  |  |  | 
| 843 |  |  |  |  |  |  | # Try to get the page 20 times. | 
| 844 | 0 |  |  |  |  |  | my $attempts = 20; | 
| 845 | 0 |  |  |  |  |  | my $res; | 
| 846 | 0 |  |  |  |  |  | my %headers = (); | 
| 847 | 0 | 0 |  |  |  |  | if ( $options{follow} ) { | 
| 848 |  |  |  |  |  |  | %headers = ( 'Referer' => $self->{current_page}->request->uri ) | 
| 849 | 0 |  |  |  |  |  | } | 
| 850 |  |  |  |  |  |  |  | 
| 851 |  |  |  |  |  |  | do { | 
| 852 |  |  |  |  |  |  |  | 
| 853 |  |  |  |  |  |  | # Try to get the page | 
| 854 |  |  |  |  |  |  | #        unless ( $res = $self->_read_cache( $url ) ) | 
| 855 | 0 |  |  |  |  |  | $res = $self->mech->get( $url, %headers); | 
| 856 |  |  |  |  |  |  | #        } | 
| 857 | 0 |  |  |  |  |  | $attempts--; | 
| 858 |  |  |  |  |  |  |  | 
| 859 | 0 |  | 0 |  |  |  | } until ( ( $self->_page_ok( $res, $options{re} ) ) || ( $attempts <= 0 ) ); | 
| 860 |  |  |  |  |  |  |  | 
| 861 |  |  |  |  |  |  | # We both set "current_page" and return the value. | 
| 862 |  |  |  |  |  |  | #    $self->_cache_page( $url, $res ) unless $self->error; | 
| 863 | 0 |  |  |  |  |  | $self->{current_page} = $res; | 
| 864 | 0 | 0 |  |  |  |  | sleep ( int( rand( 5 ) ) + 6 ) if $self->human; | 
| 865 | 0 | 0 |  |  |  |  | if ( $self->error ) { | 
| 866 | 0 |  |  |  |  |  | return undef; | 
| 867 |  |  |  |  |  |  | } else { | 
| 868 | 0 |  |  |  |  |  | return ( $res ); | 
| 869 |  |  |  |  |  |  | } | 
| 870 |  |  |  |  |  |  |  | 
| 871 |  |  |  |  |  |  | } | 
| 872 |  |  |  |  |  |  |  | 
| 873 |  |  |  |  |  |  | =head2 follow_to( $url, $regexp ) | 
| 874 |  |  |  |  |  |  |  | 
| 875 |  |  |  |  |  |  | Convenience method that calls get_page with follow => 1. | 
| 876 |  |  |  |  |  |  | Use this if you're stepping through pages. | 
| 877 |  |  |  |  |  |  |  | 
| 878 |  |  |  |  |  |  | =cut | 
| 879 |  |  |  |  |  |  |  | 
| 880 | 0 |  |  | 0 | 1 |  | sub follow_to { | 
| 881 |  |  |  |  |  |  |  | 
| 882 | 0 |  |  |  |  |  | my ( $url, $regexp ) = @_; | 
| 883 |  |  |  |  |  |  |  | 
| 884 | 0 |  |  |  |  |  | $self->get_page( $url, re => $regexp, follow => 1 ); | 
| 885 |  |  |  |  |  |  |  | 
| 886 |  |  |  |  |  |  | } | 
| 887 |  |  |  |  |  |  |  | 
| 888 |  |  |  |  |  |  | =head2 follow_link | 
| 889 |  |  |  |  |  |  |  | 
| 890 |  |  |  |  |  |  | This is the method you "should" use to navigate your sites, as it's | 
| 891 |  |  |  |  |  |  | the most "human"-looking. | 
| 892 |  |  |  |  |  |  |  | 
| 893 |  |  |  |  |  |  | This is like a robust version of WWW::Mechanize's "follow_link" | 
| 894 |  |  |  |  |  |  | method.  It calls "find_link" with your arguments (and as such takes | 
| 895 |  |  |  |  |  |  | the same arguments.  It adds the "re" argument, which is passed to | 
| 896 |  |  |  |  |  |  | get_page to verify we in fact got the page.  Returns an HTTP::Response | 
| 897 |  |  |  |  |  |  | object if it succeeds, sets $self->error and returns undef if it fails. | 
| 898 |  |  |  |  |  |  |  | 
| 899 |  |  |  |  |  |  | $self->_go_home; | 
| 900 |  |  |  |  |  |  | $self->follow_link( text_regex => qr/inbox/i, re => 'Mail Center' ) | 
| 901 |  |  |  |  |  |  | or die $self->error; | 
| 902 |  |  |  |  |  |  |  | 
| 903 |  |  |  |  |  |  | There are a lot of options, so perldoc WWW::Mechanize and search for | 
| 904 |  |  |  |  |  |  | $mech->find_link to see them all. | 
| 905 |  |  |  |  |  |  |  | 
| 906 |  |  |  |  |  |  | =cut | 
| 907 |  |  |  |  |  |  |  | 
| 908 | 0 |  |  | 0 | 1 |  | sub follow_link { | 
| 909 |  |  |  |  |  |  |  | 
| 910 | 0 |  |  |  |  |  | my ( %options ) = @_; | 
| 911 | 0 |  |  |  |  |  | my $res; | 
| 912 |  |  |  |  |  |  |  | 
| 913 |  |  |  |  |  |  | # Take out options that are just for us | 
| 914 | 0 |  |  |  |  |  | my $re = ''; | 
| 915 | 0 | 0 |  |  |  |  | if ( $options{re} ) { $re = $options{re}; delete $options{re}; } | 
|  | 0 |  |  |  |  |  |  | 
|  | 0 |  |  |  |  |  |  | 
| 916 |  |  |  |  |  |  |  | 
| 917 |  |  |  |  |  |  | # Find the link | 
| 918 | 0 |  |  |  |  |  | my $link = $self->mech->find_link( %options ); | 
| 919 |  |  |  |  |  |  |  | 
| 920 |  |  |  |  |  |  | # Follow it | 
| 921 | 0 | 0 |  |  |  |  | if ( $link ) { | 
| 922 | 0 |  |  |  |  |  | $res = $self->get_page( $link->url, re => $re, follow => 1 ); | 
| 923 | 0 |  |  |  |  |  | return $res; | 
| 924 |  |  |  |  |  |  | } else { | 
| 925 | 0 |  |  |  |  |  | $self->error('Link not found on page'); | 
| 926 | 0 |  |  |  |  |  | return undef; | 
| 927 |  |  |  |  |  |  | } | 
| 928 |  |  |  |  |  |  |  | 
| 929 |  |  |  |  |  |  | } | 
| 930 |  |  |  |  |  |  |  | 
| 931 |  |  |  |  |  |  | =head2 _cache_page( $url, $res ) | 
| 932 |  |  |  |  |  |  |  | 
| 933 |  |  |  |  |  |  | Stores $res in a cache. | 
| 934 |  |  |  |  |  |  |  | 
| 935 |  |  |  |  |  |  | =cut | 
| 936 |  |  |  |  |  |  |  | 
| 937 | 0 |  |  | 0 |  |  | sub _cache_page { | 
| 938 |  |  |  |  |  |  |  | 
| 939 | 0 |  |  |  |  |  | my ( $url, $res ) = @_; | 
| 940 |  |  |  |  |  |  |  | 
| 941 | 0 |  |  |  |  |  | $self->{page_cache}->{$url} = $res; | 
| 942 |  |  |  |  |  |  |  | 
| 943 | 0 |  |  |  |  |  | $self->_clean_cache; | 
| 944 |  |  |  |  |  |  |  | 
| 945 |  |  |  |  |  |  | } | 
| 946 |  |  |  |  |  |  |  | 
| 947 |  |  |  |  |  |  | =head2 _read_cache( $url ) | 
| 948 |  |  |  |  |  |  |  | 
| 949 |  |  |  |  |  |  | Check the cache for this page. | 
| 950 |  |  |  |  |  |  |  | 
| 951 |  |  |  |  |  |  | =cut | 
| 952 |  |  |  |  |  |  |  | 
| 953 | 0 |  |  | 0 |  |  | sub _read_cache { | 
| 954 |  |  |  |  |  |  |  | 
| 955 | 0 |  |  |  |  |  | my ( $url ) = @_; | 
| 956 |  |  |  |  |  |  |  | 
| 957 | 0 | 0 | 0 |  |  |  | if ( ( $self->{page_cache}->{$url} ) && | 
| 958 |  |  |  |  |  |  | ( $self->{page_cache}->{$url}->is_fresh ) ) { | 
| 959 | 0 |  |  |  |  |  | return $self->{page_cache}->{$url}; | 
| 960 |  |  |  |  |  |  | } else { | 
| 961 | 0 |  |  |  |  |  | return ""; | 
| 962 |  |  |  |  |  |  | } | 
| 963 |  |  |  |  |  |  |  | 
| 964 |  |  |  |  |  |  | } | 
| 965 |  |  |  |  |  |  |  | 
| 966 |  |  |  |  |  |  | =head2 _clean_cache | 
| 967 |  |  |  |  |  |  |  | 
| 968 |  |  |  |  |  |  | Cleans any non-"fresh" page from the cache. | 
| 969 |  |  |  |  |  |  |  | 
| 970 |  |  |  |  |  |  | =cut | 
| 971 |  |  |  |  |  |  |  | 
| 972 | 0 |  |  | 0 |  |  | sub _clean_cache { | 
| 973 |  |  |  |  |  |  |  | 
| 974 | 0 |  |  |  |  |  | foreach my $url ( keys( %{ $self->{'page_cache'} } ) ) { | 
|  | 0 |  |  |  |  |  |  | 
| 975 | 0 | 0 |  |  |  |  | unless ( $url->is_fresh ) { | 
| 976 | 0 |  |  |  |  |  | delete $self->{'page_cache'}->{ $url }; | 
| 977 |  |  |  |  |  |  | } | 
| 978 |  |  |  |  |  |  | } | 
| 979 |  |  |  |  |  |  |  | 
| 980 |  |  |  |  |  |  | } | 
| 981 |  |  |  |  |  |  |  | 
| 982 |  |  |  |  |  |  | #--------------------------------------------------------------------- | 
| 983 |  |  |  |  |  |  | # _page_ok( $response, $regexp ) | 
| 984 |  |  |  |  |  |  | # Takes a UserAgent response object and checks to see if the | 
| 985 |  |  |  |  |  |  | # page was sucessfully retreived, and checks the content against | 
| 986 |  |  |  |  |  |  | # known error messages (listed at the top of this file). | 
| 987 |  |  |  |  |  |  | # If passed a regexp, it will return true ONLY if the page content | 
| 988 |  |  |  |  |  |  | # matches the regexp (instead of checking the known errors). | 
| 989 |  |  |  |  |  |  | # It will delay 2 seconds if it fails so you can retry immediately. | 
| 990 |  |  |  |  |  |  | # Called by get_page and submit_form. | 
| 991 |  |  |  |  |  |  | # Sets the internal error method to 0 if there's no error, or | 
| 992 |  |  |  |  |  |  | # to a printable error message if there is an error. | 
| 993 |  |  |  |  |  |  |  | 
| 994 | 0 |  |  | 0 |  |  | sub _page_ok { | 
| 995 | 0 |  |  |  |  |  | my ( $res, $regexp ) = @_; | 
| 996 |  |  |  |  |  |  |  | 
| 997 |  |  |  |  |  |  | # Reset error | 
| 998 | 0 |  |  |  |  |  | $self->error(0); | 
| 999 |  |  |  |  |  |  |  | 
| 1000 |  |  |  |  |  |  | # Check for errors | 
| 1001 | 0 |  |  |  |  |  | my $page_ok = 1; | 
| 1002 | 0 |  |  |  |  |  | my $page; | 
| 1003 |  |  |  |  |  |  | my $errors; | 
| 1004 |  |  |  |  |  |  |  | 
| 1005 |  |  |  |  |  |  | # If we think we're logged in, check for the "You must be logged-in" | 
| 1006 |  |  |  |  |  |  | # error page. | 
| 1007 | 0 | 0 | 0 |  |  |  | if ( ( $self->logged_in ) && ( ! $self->_check_login( $res ) ) ) { | 
|  |  | 0 |  |  |  |  |  | 
| 1008 | 0 |  |  |  |  |  | $self->error( "Not logged in" ); | 
| 1009 | 0 |  |  |  |  |  | $page_ok=0; | 
| 1010 |  |  |  |  |  |  | } | 
| 1011 |  |  |  |  |  |  |  | 
| 1012 |  |  |  |  |  |  | # If the page load is "successful", check for other problems. | 
| 1013 |  |  |  |  |  |  | elsif ( $res->is_success ) { | 
| 1014 |  |  |  |  |  |  |  | 
| 1015 |  |  |  |  |  |  | # Page loaded, but make sure it isn't an error page. | 
| 1016 | 0 |  |  |  |  |  | $page = $res->decoded_content; # Get the content | 
| 1017 | 0 |  |  |  |  |  | $page =~ s/[ \t\n\r]+/ /g; # Strip whitespace | 
| 1018 |  |  |  |  |  |  |  | 
| 1019 |  |  |  |  |  |  | # If they gave us a RE with which to verify the page, look for it. | 
| 1020 | 0 | 0 |  |  |  |  | if ( $regexp ) { | 
| 1021 |  |  |  |  |  |  | # Page must match the regexp | 
| 1022 | 0 | 0 |  |  |  |  | unless ( $page =~ /$regexp/ism ) { | 
| 1023 | 0 |  |  |  |  |  | $page_ok = 0; | 
| 1024 | 0 |  |  |  |  |  | $self->error("Page doesn't match verification pattern."); | 
| 1025 |  |  |  |  |  |  | #                warn "Page doesn't match verification pattern.\n"; | 
| 1026 |  |  |  |  |  |  | } | 
| 1027 |  |  |  |  |  |  |  | 
| 1028 |  |  |  |  |  |  | # Otherwise, look for our known temporary errors. | 
| 1029 |  |  |  |  |  |  | } else { | 
| 1030 | 0 | 0 |  |  |  |  | if ( defined $self->site_info->{'error_regexs'} ) { | 
| 1031 | 0 |  |  |  |  |  | $errors = $self->site_info->{'error_regexs'}; | 
| 1032 | 0 |  |  |  |  |  | foreach my $error_regex ( @{$errors} ) { | 
|  | 0 |  |  |  |  |  |  | 
| 1033 | 0 | 0 |  |  |  |  | if ( $page =~ /$error_regex/ism ) { | 
| 1034 | 0 |  |  |  |  |  | $page_ok = 0; | 
| 1035 | 0 |  |  |  |  |  | $self->error( "Got error page." ); | 
| 1036 |  |  |  |  |  |  | #                        warn "Got error page.\n"; | 
| 1037 | 0 |  |  |  |  |  | last; | 
| 1038 |  |  |  |  |  |  | } | 
| 1039 |  |  |  |  |  |  | } | 
| 1040 |  |  |  |  |  |  | } | 
| 1041 |  |  |  |  |  |  | } | 
| 1042 |  |  |  |  |  |  |  | 
| 1043 |  |  |  |  |  |  | } else { | 
| 1044 |  |  |  |  |  |  |  | 
| 1045 | 0 |  |  |  |  |  | $self->error("Error getting page: \n" . | 
| 1046 |  |  |  |  |  |  | "  " . $res->status_line); | 
| 1047 | 0 |  |  |  |  |  | $page_ok = 0; | 
| 1048 |  |  |  |  |  |  |  | 
| 1049 | 0 |  |  |  |  |  | warn "Error getting page: \n" . | 
| 1050 |  |  |  |  |  |  | "  " . $res->status_line . "\n"; | 
| 1051 |  |  |  |  |  |  |  | 
| 1052 |  |  |  |  |  |  | } | 
| 1053 |  |  |  |  |  |  |  | 
| 1054 | 0 | 0 |  |  |  |  | sleep 2 unless ( $page_ok ); | 
| 1055 |  |  |  |  |  |  |  | 
| 1056 | 0 |  |  |  |  |  | return $page_ok; | 
| 1057 |  |  |  |  |  |  |  | 
| 1058 |  |  |  |  |  |  | } | 
| 1059 |  |  |  |  |  |  |  | 
| 1060 |  |  |  |  |  |  |  | 
| 1061 |  |  |  |  |  |  | =head2 submit_form( %options ) | 
| 1062 |  |  |  |  |  |  |  | 
| 1063 |  |  |  |  |  |  | Valid options: | 
| 1064 |  |  |  |  |  |  | $site->submit_form( | 
| 1065 |  |  |  |  |  |  | page => "http://some.url.org/formpage.html", | 
| 1066 |  |  |  |  |  |  | form_no => 1, | 
| 1067 |  |  |  |  |  |  | form_name => "myform",  # Use this OR form_no OR form | 
| 1068 |  |  |  |  |  |  | form => $form, # HTML::Form object with a ready-to-post form. | 
| 1069 |  |  |  |  |  |  | # (page, form_no, form_name, fields_ref and action will | 
| 1070 |  |  |  |  |  |  | # be ignored). | 
| 1071 |  |  |  |  |  |  | button => "mybutton", | 
| 1072 |  |  |  |  |  |  | no_click => 0,  # 0 or 1. | 
| 1073 |  |  |  |  |  |  | fields_ref => { field => 'value', field2 => 'value' }, | 
| 1074 |  |  |  |  |  |  | re1 => 'something unique.?about this[ \t\n]+page', | 
| 1075 |  |  |  |  |  |  | re2 => 'something unique about the submitted page', | 
| 1076 |  |  |  |  |  |  | action => 'http://some.url.org/newpostpage.cgi', # Only needed in weird occasions | 
| 1077 |  |  |  |  |  |  | ); | 
| 1078 |  |  |  |  |  |  |  | 
| 1079 |  |  |  |  |  |  | This powerful little method reads the web page specified by "page", | 
| 1080 |  |  |  |  |  |  | finds the form specified by "form_no" or "form_name", fills in the values | 
| 1081 |  |  |  |  |  |  | specified in "fields_ref", and clicks the button named "button". | 
| 1082 |  |  |  |  |  |  |  | 
| 1083 |  |  |  |  |  |  | You may or may not need this method - it's used internally by | 
| 1084 |  |  |  |  |  |  | any method that needs to fill in and post a form. I made it | 
| 1085 |  |  |  |  |  |  | public just in case you need to fill in and post a form that's not | 
| 1086 |  |  |  |  |  |  | handled by another method (in which case, see CONTRIBUTING below :). | 
| 1087 |  |  |  |  |  |  |  | 
| 1088 |  |  |  |  |  |  | "page" can either be a text string that is a URL or a reference to an | 
| 1089 |  |  |  |  |  |  | HTTP::Response object that contains the source of the page | 
| 1090 |  |  |  |  |  |  | that contains the form. If it is an empty string or not specified, | 
| 1091 |  |  |  |  |  |  | the current page ( $site->current_page ) is used. | 
| 1092 |  |  |  |  |  |  |  | 
| 1093 |  |  |  |  |  |  | "form_no" is used to numerically identify the form on the page. It's a | 
| 1094 |  |  |  |  |  |  | simple counter starting from 1.  If there are 3 forms on the page and | 
| 1095 |  |  |  |  |  |  | you want to fill in and submit the second form, set "form_no => 2". | 
| 1096 |  |  |  |  |  |  | For the first form, use "form_no => 1". | 
| 1097 |  |  |  |  |  |  |  | 
| 1098 |  |  |  |  |  |  | "form_name" is used to indentify the form by name.  In actuality, | 
| 1099 |  |  |  |  |  |  | submit_form simply uses "form_name" to iterate through the forms | 
| 1100 |  |  |  |  |  |  | and sets "form_no" for you. | 
| 1101 |  |  |  |  |  |  |  | 
| 1102 |  |  |  |  |  |  | "form" can be used if you have a customized form you want to submit. | 
| 1103 |  |  |  |  |  |  | Pass an HTML::Form object and set "button", "no_click", and "re2" | 
| 1104 |  |  |  |  |  |  | as desired, and you can use submit_form's tenacious submission routine | 
| 1105 |  |  |  |  |  |  | with your own values. | 
| 1106 |  |  |  |  |  |  |  | 
| 1107 |  |  |  |  |  |  | "button" is the name of the button to submit. This will frequently | 
| 1108 |  |  |  |  |  |  | be "submit", but if they've named the button something clever like | 
| 1109 |  |  |  |  |  |  | "Submit22" (as MySpace did in their login form), then you may have to | 
| 1110 |  |  |  |  |  |  | use that.  If no button is specified (either by button => '' or by | 
| 1111 |  |  |  |  |  |  | not specifying button at all), the first button on the form | 
| 1112 |  |  |  |  |  |  | is clicked. | 
| 1113 |  |  |  |  |  |  |  | 
| 1114 |  |  |  |  |  |  | If "no_click" is set to 1, the form willl be submitted without | 
| 1115 |  |  |  |  |  |  | clicking any button.   This is used to simulate the JavaScript | 
| 1116 |  |  |  |  |  |  | form submits Myspace does on the browse pages. | 
| 1117 |  |  |  |  |  |  |  | 
| 1118 |  |  |  |  |  |  | "fields_ref" is a reference to a hash that contains field names | 
| 1119 |  |  |  |  |  |  | and values you want to fill in on the form. | 
| 1120 |  |  |  |  |  |  | For checkboxes with no "value" attribute, specify a value of "on" | 
| 1121 |  |  |  |  |  |  | to check it, "off" to uncheck it. | 
| 1122 |  |  |  |  |  |  |  | 
| 1123 |  |  |  |  |  |  | "re1" is an optional Regular Expression that will be used to make | 
| 1124 |  |  |  |  |  |  | sure the proper form page has been loaded. The page content will | 
| 1125 |  |  |  |  |  |  | be matched to the RE, and will be treated as an error page and retried | 
| 1126 |  |  |  |  |  |  | until it matches. See get_page for more info. | 
| 1127 |  |  |  |  |  |  |  | 
| 1128 |  |  |  |  |  |  | "re2" is an optional RE that will me used to make sure that the | 
| 1129 |  |  |  |  |  |  | post was successful. USE THIS CAREFULLY! If your RE breaks, you could | 
| 1130 |  |  |  |  |  |  | end up repeatedly posting a form. | 
| 1131 |  |  |  |  |  |  |  | 
| 1132 |  |  |  |  |  |  | "action" is the post action for the form, as in: | 
| 1133 |  |  |  |  |  |  |  | 
| 1134 |  |  |  |  |  |  |  | 
| 1135 |  |  |  |  |  |  |  | 
| 1136 |  |  |  |  |  |  | This is here because Myspace likes to do weird things like reset | 
| 1137 |  |  |  |  |  |  | form actions with Javascript then post them without clicking form buttons. | 
| 1138 |  |  |  |  |  |  |  | 
| 1139 |  |  |  |  |  |  | EXAMPLE | 
| 1140 |  |  |  |  |  |  |  | 
| 1141 |  |  |  |  |  |  | This is how WWW::Myspace's post_comment method posted a comment: | 
| 1142 |  |  |  |  |  |  |  | 
| 1143 |  |  |  |  |  |  | # Submit the comment to $friend_id's page | 
| 1144 |  |  |  |  |  |  | $self->submit_form( "${VIEW_COMMENT_FORM}${friend_id}", 1, "submit", | 
| 1145 |  |  |  |  |  |  | { 'f_comments' => "$message" }, '', 'f_comments' | 
| 1146 |  |  |  |  |  |  | ); | 
| 1147 |  |  |  |  |  |  |  | 
| 1148 |  |  |  |  |  |  | # Confirm it | 
| 1149 |  |  |  |  |  |  | $self->submit_form( "", 1, "submit", {} ); | 
| 1150 |  |  |  |  |  |  |  | 
| 1151 |  |  |  |  |  |  | =cut | 
| 1152 |  |  |  |  |  |  |  | 
| 1153 |  |  |  |  |  |  |  | 
| 1154 | 0 |  |  | 0 | 1 |  | sub submit_form { | 
| 1155 |  |  |  |  |  |  |  | 
| 1156 | 0 |  |  |  |  |  | my ( %options ) = @_; | 
| 1157 |  |  |  |  |  |  |  | 
| 1158 |  |  |  |  |  |  | # Initialize our variables | 
| 1159 | 0 |  |  |  |  |  | my $mech = $self->mech; # For convenience | 
| 1160 | 0 |  |  |  |  |  | my $res = ""; | 
| 1161 | 0 |  |  |  |  |  | my ( $field, $form_no ); | 
| 1162 |  |  |  |  |  |  |  | 
| 1163 |  |  |  |  |  |  | # If they gave us a form, use it.  Otherwise, get it and fill it in. | 
| 1164 | 0 |  |  |  |  |  | my $f = ""; | 
| 1165 | 0 | 0 |  |  |  |  | if ( $options{'form'} ) { | 
| 1166 | 0 |  |  |  |  |  | $f = $options{'form'}; | 
| 1167 |  |  |  |  |  |  | } else { | 
| 1168 |  |  |  |  |  |  | # Get the page | 
| 1169 | 0 | 0 |  |  |  |  | if ( ref( $options{'page'} ) eq "HTTP::Response" ) { | 
|  |  | 0 |  |  |  |  |  | 
| 1170 |  |  |  |  |  |  | # They gave us a page already | 
| 1171 | 0 |  |  |  |  |  | $res = $options{'page'}; | 
| 1172 |  |  |  |  |  |  | } elsif ( ! $options{'page'} ) { | 
| 1173 | 0 |  |  |  |  |  | $res = $self->current_page; | 
| 1174 |  |  |  |  |  |  | } else { | 
| 1175 |  |  |  |  |  |  | # Get the page | 
| 1176 | 0 |  |  |  |  |  | $res = $self->get_page( $options{'page'}, re => $options{'re1'} ); | 
| 1177 |  |  |  |  |  |  | # If we couldn't get the page, return failure. | 
| 1178 | 0 | 0 |  |  |  |  | return 0 if $self->error; | 
| 1179 |  |  |  |  |  |  | } | 
| 1180 |  |  |  |  |  |  |  | 
| 1181 |  |  |  |  |  |  | # Select the form they wanted, or return failure if we can't. | 
| 1182 | 0 |  |  |  |  |  | my @forms = HTML::Form->parse( $res ); | 
| 1183 | 0 | 0 |  |  |  |  | if ( $options{'form_no'} ) { | 
| 1184 | 0 |  |  |  |  |  | $options{'form_no'}--; # To be like WWW::Mechanize; | 
| 1185 | 0 | 0 |  |  |  |  | unless ( @forms > $options{'form_no'} ) { | 
| 1186 | 0 |  |  |  |  |  | $self->error( "Form not on page in submit_form!" ); | 
| 1187 | 0 |  |  |  |  |  | return 0; | 
| 1188 |  |  |  |  |  |  | } | 
| 1189 |  |  |  |  |  |  | } | 
| 1190 | 0 | 0 |  |  |  |  | if ( $options{'form_name'} ) { | 
| 1191 | 0 |  |  |  |  |  | $form_no = 0; | 
| 1192 | 0 |  |  |  |  |  | foreach my $form ( @forms ) { | 
| 1193 | 0 | 0 | 0 |  |  |  | if ( ( $form->attr( 'name' ) ) && ( $form->attr( 'name' ) eq $options{'form_name'} ) ) { | 
| 1194 | 0 |  |  |  |  |  | $options{'form_no'} = $form_no; | 
| 1195 | 0 |  |  |  |  |  | last; | 
| 1196 |  |  |  |  |  |  | } | 
| 1197 | 0 |  |  |  |  |  | $form_no++; | 
| 1198 |  |  |  |  |  |  | } | 
| 1199 |  |  |  |  |  |  | } | 
| 1200 |  |  |  |  |  |  |  | 
| 1201 | 0 |  |  |  |  |  | $f = $forms[ $options{'form_no'} ]; | 
| 1202 |  |  |  |  |  |  | } | 
| 1203 |  |  |  |  |  |  |  | 
| 1204 |  |  |  |  |  |  | # Set the action if they gave us one | 
| 1205 | 0 | 0 |  |  |  |  | if ( $options{'action'} ) { $f->action( $options{'action'} ) } | 
|  | 0 |  |  |  |  |  |  | 
| 1206 |  |  |  |  |  |  |  | 
| 1207 |  |  |  |  |  |  | # Loop through the fields in the form and set them. | 
| 1208 | 0 |  |  |  |  |  | foreach my $field ( keys %{ $options{'fields_ref'} } ) { | 
|  | 0 |  |  |  |  |  |  | 
| 1209 |  |  |  |  |  |  | # If the field "exists" on the form, just fill it in, | 
| 1210 |  |  |  |  |  |  | # otherwise, add it as a hidden field. | 
| 1211 | 0 | 0 |  |  |  |  | if ( $f->find_input( $field ) ) { | 
| 1212 | 0 | 0 |  |  |  |  | if ( $f->find_input( $field )->readonly ) { | 
| 1213 | 0 |  |  |  |  |  | $f->find_input( $field )->readonly(0) | 
| 1214 |  |  |  |  |  |  | } | 
| 1215 | 0 |  |  |  |  |  | $f->param( $field, $options{'fields_ref'}->{ $field } ); | 
| 1216 |  |  |  |  |  |  | } else { | 
| 1217 | 0 |  |  |  |  |  | $f = $self->_add_to_form( $f, $field, $options{'fields_ref'}->{ $field } ); | 
| 1218 |  |  |  |  |  |  | } | 
| 1219 |  |  |  |  |  |  | } | 
| 1220 |  |  |  |  |  |  |  | 
| 1221 | 0 | 0 |  |  |  |  | if ( $options{'die'} ) { print $f->dump; die } | 
|  | 0 |  |  |  |  |  |  | 
|  | 0 |  |  |  |  |  |  | 
| 1222 |  |  |  |  |  |  |  | 
| 1223 |  |  |  |  |  |  | # Submit the form.  Try up to $attempts times. | 
| 1224 | 0 |  |  |  |  |  | my $attempts = 5; | 
| 1225 | 0 |  |  |  |  |  | my $trying_again = 0; | 
| 1226 |  |  |  |  |  |  | do | 
| 1227 |  |  |  |  |  |  | { | 
| 1228 |  |  |  |  |  |  | # If we're trying again, mention it. | 
| 1229 | 0 | 0 |  |  |  |  | warn $self->error . "\n" if $trying_again; | 
| 1230 |  |  |  |  |  |  |  | 
| 1231 | 0 |  |  |  |  |  | eval { | 
| 1232 | 0 | 0 |  |  |  |  | if ( $options{'button'} ) { | 
|  |  | 0 |  |  |  |  |  | 
| 1233 | 0 |  |  |  |  |  | $res = $self->mech->request( $f->click( $options{'button'} ) ); | 
| 1234 |  |  |  |  |  |  | } elsif ( $options{'no_click'} ) { | 
| 1235 |  |  |  |  |  |  | # We use make_request because some sites like submitting forms | 
| 1236 |  |  |  |  |  |  | # that have buttons by using Javascript. make_request submits | 
| 1237 |  |  |  |  |  |  | # the form without clicking anything, whereas "click" clicks | 
| 1238 |  |  |  |  |  |  | # the first button, which can break things. | 
| 1239 | 0 |  |  |  |  |  | $res = $self->mech->request( $f->make_request ); | 
| 1240 |  |  |  |  |  |  | } else { | 
| 1241 |  |  |  |  |  |  | # Just click the first button | 
| 1242 | 0 |  |  |  |  |  | $res = $self->mech->request( $f->click ); | 
| 1243 |  |  |  |  |  |  | } | 
| 1244 |  |  |  |  |  |  | }; | 
| 1245 |  |  |  |  |  |  |  | 
| 1246 |  |  |  |  |  |  | # If it died (it will if there's no button), just return failure. | 
| 1247 | 0 | 0 |  |  |  |  | if ( $@ ) { | 
| 1248 | 0 |  |  |  |  |  | $self->error( $@ ); | 
| 1249 | 0 |  |  |  |  |  | return 0; | 
| 1250 |  |  |  |  |  |  | } | 
| 1251 |  |  |  |  |  |  |  | 
| 1252 | 0 |  |  |  |  |  | $attempts--; | 
| 1253 | 0 |  |  |  |  |  | $trying_again = 1; | 
| 1254 |  |  |  |  |  |  |  | 
| 1255 | 0 |  | 0 |  |  |  | } until ( ( $self->_page_ok( $res, $options{'re2'} ) ) || ( $attempts <= 0 ) ); | 
| 1256 |  |  |  |  |  |  |  | 
| 1257 |  |  |  |  |  |  | # Return the result | 
| 1258 | 0 |  |  |  |  |  | $self->{current_page} = $res; | 
| 1259 | 0 |  |  |  |  |  | return ( ! $self->error ); | 
| 1260 |  |  |  |  |  |  |  | 
| 1261 |  |  |  |  |  |  | } | 
| 1262 |  |  |  |  |  |  |  | 
| 1263 |  |  |  |  |  |  | =head2 _add_to_form | 
| 1264 |  |  |  |  |  |  |  | 
| 1265 |  |  |  |  |  |  | Internal method to add a hidden field to a form. HTML::Form thinks we | 
| 1266 |  |  |  |  |  |  | don't want to change hidden fields, and if a hidden field has no value, | 
| 1267 |  |  |  |  |  |  | it won't even create an input object for it.  If that's way over your | 
| 1268 |  |  |  |  |  |  | head don't worry, it just means we're fixing things with this method, | 
| 1269 |  |  |  |  |  |  | and submit_form will call this method for you if you pass it a field that | 
| 1270 |  |  |  |  |  |  | doesn't show up on the form. | 
| 1271 |  |  |  |  |  |  |  | 
| 1272 |  |  |  |  |  |  | Returns a form object that is the old form with the new field in it. | 
| 1273 |  |  |  |  |  |  |  | 
| 1274 |  |  |  |  |  |  | # Add field $fieldname to form $form (a HTML::Form object) and | 
| 1275 |  |  |  |  |  |  | # set it's value to $value. | 
| 1276 |  |  |  |  |  |  | $self->_add_to_form( $form, $fieldname, $value ) | 
| 1277 |  |  |  |  |  |  |  | 
| 1278 |  |  |  |  |  |  | =cut | 
| 1279 |  |  |  |  |  |  |  | 
| 1280 | 0 |  |  | 0 |  |  | sub _add_to_form { | 
| 1281 |  |  |  |  |  |  |  | 
| 1282 | 0 |  |  |  |  |  | my ( $f, $field, $value ) = @_; | 
| 1283 |  |  |  |  |  |  |  | 
| 1284 | 0 |  |  |  |  |  | $f->push_input( 'hidden', { name => $field, value => $value } ); | 
| 1285 |  |  |  |  |  |  |  | 
| 1286 | 0 |  |  |  |  |  | return $f; | 
| 1287 |  |  |  |  |  |  | } | 
| 1288 |  |  |  |  |  |  |  | 
| 1289 |  |  |  |  |  |  | =head2 _go_home | 
| 1290 |  |  |  |  |  |  |  | 
| 1291 |  |  |  |  |  |  | Internal method to go to the home page.  Checks to see if we're already | 
| 1292 |  |  |  |  |  |  | there.  If not, tries to click the Home button on the page.  If there | 
| 1293 |  |  |  |  |  |  | isn't one, loads the page explicitly. | 
| 1294 |  |  |  |  |  |  |  | 
| 1295 |  |  |  |  |  |  | =cut | 
| 1296 |  |  |  |  |  |  |  | 
| 1297 | 0 |  |  | 0 |  |  | sub _go_home { | 
| 1298 |  |  |  |  |  |  |  | 
| 1299 | 0 |  |  |  |  |  | my $link_re = $self->site_info->{'home_link_re'}; | 
| 1300 | 0 |  |  |  |  |  | my $home_uri_re = $self->site_info->{'home_uri_re'}; | 
| 1301 |  |  |  |  |  |  |  | 
| 1302 |  |  |  |  |  |  | # If we're not logged in, go to the site's home page | 
| 1303 | 0 | 0 |  |  |  |  | unless ( $self->logged_in ) { | 
| 1304 | 0 |  |  |  |  |  | $self->get_page( $self->site_info->{'home_page'} ); | 
| 1305 | 0 |  |  |  |  |  | return; | 
| 1306 |  |  |  |  |  |  | } | 
| 1307 |  |  |  |  |  |  |  | 
| 1308 |  |  |  |  |  |  | # Are we there? | 
| 1309 | 0 | 0 |  |  |  |  | if ( $self->mech->uri =~ /$home_uri_re/i ) { | 
| 1310 |  |  |  |  |  |  | #        warn "I think I'm on the homepage\n"; | 
| 1311 |  |  |  |  |  |  | #        warn $self->mech->uri . "\n"; | 
| 1312 | 0 |  |  |  |  |  | return; | 
| 1313 |  |  |  |  |  |  | } | 
| 1314 |  |  |  |  |  |  |  | 
| 1315 |  |  |  |  |  |  | # No, try to click home | 
| 1316 | 0 |  |  |  |  |  | my $home_link = ""; | 
| 1317 | 0 | 0 |  |  |  |  | if ( $home_link = $self->mech->find_link( url_regex => qr/$link_re/i ) ) { | 
| 1318 |  |  |  |  |  |  | #        warn "_go_home going to " . $home_link->url . "\n"; | 
| 1319 | 0 |  |  |  |  |  | $self->get_page( $home_link->url ); | 
| 1320 | 0 |  |  |  |  |  | return; | 
| 1321 |  |  |  |  |  |  | } | 
| 1322 |  |  |  |  |  |  |  | 
| 1323 |  |  |  |  |  |  | # Still here?  Load the page explicitly | 
| 1324 | 0 |  |  |  |  |  | $self->get_page( $self->site_info->{'home_url'} ); | 
| 1325 |  |  |  |  |  |  | #    warn "I think I loaded $HOME_PAGE\n"; | 
| 1326 |  |  |  |  |  |  |  | 
| 1327 | 0 |  |  |  |  |  | return; | 
| 1328 |  |  |  |  |  |  |  | 
| 1329 |  |  |  |  |  |  | } | 
| 1330 |  |  |  |  |  |  |  | 
| 1331 |  |  |  |  |  |  | =head2 make_cache_dir | 
| 1332 |  |  |  |  |  |  |  | 
| 1333 |  |  |  |  |  |  | Creates the cache directory in cache_dir. Only creates the | 
| 1334 |  |  |  |  |  |  | top-level directory, croaks if it can't create it. | 
| 1335 |  |  |  |  |  |  |  | 
| 1336 |  |  |  |  |  |  | $myspace->cache_dir("/path/to/dir"); | 
| 1337 |  |  |  |  |  |  | $myspace->make_cache_dir; | 
| 1338 |  |  |  |  |  |  |  | 
| 1339 |  |  |  |  |  |  | This function mainly exists for the internal login method to use, | 
| 1340 |  |  |  |  |  |  | and for related sub-modules that store their cache files by | 
| 1341 |  |  |  |  |  |  | default in WWW:Myspace's cache directory. | 
| 1342 |  |  |  |  |  |  |  | 
| 1343 |  |  |  |  |  |  | =cut | 
| 1344 |  |  |  |  |  |  |  | 
| 1345 | 0 |  |  | 0 | 1 |  | sub make_cache_dir { | 
| 1346 |  |  |  |  |  |  |  | 
| 1347 |  |  |  |  |  |  | # Make the cache directory if it doesn't exist. | 
| 1348 | 0 | 0 |  |  |  |  | unless ( -d $self->cache_dir ) { | 
| 1349 | 0 | 0 |  |  |  |  | mkdir $self->cache_dir or croak "Can't create cache directory ". | 
| 1350 |  |  |  |  |  |  | $self->cache_dir; | 
| 1351 |  |  |  |  |  |  | } | 
| 1352 |  |  |  |  |  |  |  | 
| 1353 |  |  |  |  |  |  | } | 
| 1354 |  |  |  |  |  |  |  | 
| 1355 |  |  |  |  |  |  | =head2 debug( message ); | 
| 1356 |  |  |  |  |  |  |  | 
| 1357 |  |  |  |  |  |  | Use this method to turn on/off debugging output. | 
| 1358 |  |  |  |  |  |  |  | 
| 1359 |  |  |  |  |  |  | =cut | 
| 1360 |  |  |  |  |  |  |  | 
| 1361 | 0 |  |  | 0 | 1 |  | sub debug { | 
| 1362 | 0 |  |  |  |  |  | my ( $message ) = @_; | 
| 1363 |  |  |  |  |  |  |  | 
| 1364 |  |  |  |  |  |  | #   warn $message . "\n"; | 
| 1365 |  |  |  |  |  |  |  | 
| 1366 |  |  |  |  |  |  | } | 
| 1367 |  |  |  |  |  |  |  | 
| 1368 |  |  |  |  |  |  | =head1 AUTHOR | 
| 1369 |  |  |  |  |  |  |  | 
| 1370 |  |  |  |  |  |  | Grant Grueninger, C<<  >> | 
| 1371 |  |  |  |  |  |  |  | 
| 1372 |  |  |  |  |  |  | =head1 BUGS | 
| 1373 |  |  |  |  |  |  |  | 
| 1374 |  |  |  |  |  |  | Please report any bugs or feature requests to | 
| 1375 |  |  |  |  |  |  | C, or through the web interface at | 
| 1376 |  |  |  |  |  |  | L. | 
| 1377 |  |  |  |  |  |  | I will be notified, and then you'll automatically be notified of progress on | 
| 1378 |  |  |  |  |  |  | your bug as I make changes. | 
| 1379 |  |  |  |  |  |  |  | 
| 1380 |  |  |  |  |  |  | =head1 SUPPORT | 
| 1381 |  |  |  |  |  |  |  | 
| 1382 |  |  |  |  |  |  | You can find documentation for this module with the perldoc command. | 
| 1383 |  |  |  |  |  |  |  | 
| 1384 |  |  |  |  |  |  | perldoc WWW::Bebo | 
| 1385 |  |  |  |  |  |  |  | 
| 1386 |  |  |  |  |  |  | You can also look for information at: | 
| 1387 |  |  |  |  |  |  |  | 
| 1388 |  |  |  |  |  |  | =over 4 | 
| 1389 |  |  |  |  |  |  |  | 
| 1390 |  |  |  |  |  |  | =item * AnnoCPAN: Annotated CPAN documentation | 
| 1391 |  |  |  |  |  |  |  | 
| 1392 |  |  |  |  |  |  | L | 
| 1393 |  |  |  |  |  |  |  | 
| 1394 |  |  |  |  |  |  | =item * CPAN Ratings | 
| 1395 |  |  |  |  |  |  |  | 
| 1396 |  |  |  |  |  |  | L | 
| 1397 |  |  |  |  |  |  |  | 
| 1398 |  |  |  |  |  |  | =item * RT: CPAN's request tracker | 
| 1399 |  |  |  |  |  |  |  | 
| 1400 |  |  |  |  |  |  | L | 
| 1401 |  |  |  |  |  |  |  | 
| 1402 |  |  |  |  |  |  | =item * Search CPAN | 
| 1403 |  |  |  |  |  |  |  | 
| 1404 |  |  |  |  |  |  | L | 
| 1405 |  |  |  |  |  |  |  | 
| 1406 |  |  |  |  |  |  | =back | 
| 1407 |  |  |  |  |  |  |  | 
| 1408 |  |  |  |  |  |  | =head1 ACKNOWLEDGEMENTS | 
| 1409 |  |  |  |  |  |  |  | 
| 1410 |  |  |  |  |  |  | =head1 COPYRIGHT & LICENSE | 
| 1411 |  |  |  |  |  |  |  | 
| 1412 |  |  |  |  |  |  | Copyright 2006 Grant Grueninger, all rights reserved. | 
| 1413 |  |  |  |  |  |  |  | 
| 1414 |  |  |  |  |  |  | This program is free software; you can redistribute it and/or modify it | 
| 1415 |  |  |  |  |  |  | under the same terms as Perl itself. | 
| 1416 |  |  |  |  |  |  |  | 
| 1417 |  |  |  |  |  |  | =cut | 
| 1418 |  |  |  |  |  |  |  | 
| 1419 |  |  |  |  |  |  | 1; # End of WWW::Bebo |