A “like” gomb működése és a cookie-k

Nézzük a két részletet, amelyek az előző részből kimaradtak. Az első rész a számláló növeléséért felelős. Ezt egy sima adatbázis UPDATE végzi a DBI interfészen keresztül. Fontos, hogy a finish() metódussal felszabadítsuk az utasítást, különben “lógna” a levegőben azaz a memóriában. A cookie-zás (sütizés) az egy kliensből történő többszöri like-olás megakadályozását szolgálja és az üzenetfejlécben állítjuk illetve kérdezzük le, mégis teszt célokból jelen kódban ki van “ütve”.

 my $cookie = $r->headers_in->get('Cookie');
 my $uri = URI::Encode->new( { encode_reserved => 1 } );
 my $uri_encoded_referer = $uri->encode($http_referer);
 #print $uri_encoded_referer;
 my $wasliked = $cookie ne '' && $cookie =~ /$uri_encoded_referer/;
 if ($like && ! $wasliked ) {
  # increment counter
  my $sthupd = $dbh->prepare('UPDATE mylike SET counter = counter + 1 WHERE approved = 1 and referer = ?');
  $sthupd->execute($http_referer);
  $sthupd->finish();

  my $cookie = CGI::Cookie->new(-name  => 'mylike'.$http_referer,
                                -value => 'SET');
  $r->headers_out->set('Set-Cookie' => $cookie);
  $wasliked = 1;

  # !! TEST ONLY !! temporary turn off cookie-mechanism !! COMMMENT OUT FOLLOWING TWO LINES FOR USE !!
  $r->headers_out->set('Set-Cookie' => '');
  $wasliked = 0;
 }

A like változó értékadása az előző részben szerepel, a GET metódus révén átadott paraméterként kerül kiértékelésre. Az alábbi gomb onclick javascript eseményéből kerül meghívásra like=1 URI változóként.

my $req = CGI->new($r);
my $like = $req->param('like');

A második kimaradt részecske maga a “like” gomb megjelenítéséért felelős. Ha már like-oltuk az oldalt, akkor disabled a gomb, azaz nem lehet többször megnyomni. 🙂

 print "<input type=\"button\" onclick=\"\$('#mylike').load('http://localhost/perl/mylike-dbi.cgi?like=1');\" value=\"like\" ".($wasliked?'disabled ':'')."/>\n";

És akkor nézzük meg a kimenetet!

Ennyi! That’s all! 🙂

Megjegyzés: azért a felhasznált javascript miatt ügyelni kell arra, hogy a site-unk include-olja script forrásként a jquery lib-eket.

Az utolsó részben megnézzük, hogyan lehet letesztelni illetve a teherbírását megmérni a like modulunknak.

A like-számlálójának működése, a REFERER a HTTP fejlécből

Minden további leírás helyett ideollózom a mylike-dbi.cgi azon részeit, amelyek a like-ok számának megjelenítéséért felelősek, illetve amelyek az első bejegyzés létrehozására alkalmasak.

#!/usr/bin/perl

use strict;
use warnings;
use DBI;
use Apache2::RequestRec ();
use Apache2::RequestUtil ();
use CGI;
use CGI::Cookie;
use URI::Encode;


my $r = Apache2::RequestUtil->request;

my $req = CGI->new($r);
my $like = $req->param('like');
#print $like;
my $http_referer = $ENV{'HTTP_REFERER'};

my $dbh = DBI->connect('DBI:mysql:mylike', 'mylike', 'mylike1'
                   ) || die "Could not connect to database: $DBI::errstr";

if ($http_referer) {

 # LIKE BUTTON CODE WAS HERE ##################

 my $sth = $dbh->prepare('SELECT id FROM mylike WHERE approved = 1 and referer = ?');
 $sth->execute($http_referer);
 my @result = $sth->fetchrow_array();
 my $len = @result;
 #print "numof result $len\n";
 $sth->finish();

 if ($len == 0) {
  # insert data into the links table
  my $sql = "INSERT INTO mylike (referer) VALUES(?)";

  my $stmt = $dbh->prepare($sql);

  # execute the query
  if($stmt->execute($http_referer)) {
   # ok
   #print "Mylike $http_referer inserted successfully";
  }

  $stmt->finish();
 }

 $sth = $dbh->prepare('SELECT counter FROM mylike WHERE approved = 1 and referer = ?');
 $sth->execute($http_referer);
 @result = $sth->fetchrow_array();

 print "$result[0] like(s)<br>\n";

 # LIKE BUTTON CODE WAS HERE ##################

 $sth->finish();
 
} else {
 # test

 my $results = $dbh->selectall_hashref('SELECT * FROM mylike', 'id');
 foreach my $id (keys %$results) {
  print "!!TEST!! ID $id: referer is $results->{$id}->{'referer'}, counter is $results->{$id}->{'counter'}\n";
 }

}

$dbh->disconnect();

A kód magyarázata.

Kivesszük a fejlécből a HTTP_REFERER-t. Ha ez definiált, akkor “éles” működés, ha nem akkor tesztüzemmód. Tesztüzemben az alábbi kimenetet kapjuk.

Látható, hogy két REFERER szerepel az adatbázisunkban. Ezeket sorolja fel tesztüzemmódban a script.

Éles üzemnél megvizsgálja a programunk, hogy létezik-e adatbázis-bejegyzés adott REFERER-rel. Ha még nincs, létrehoz egyet 0-ás like-oltsággal. 🙂 Ezután egy sima print utasítással kijelzi a kedvelések számát.

A következő részben megnézhetjük magának a “like” gombnak is a működését és a mögötte álló programkódot is. Ebben a forrásban ezt a

# LIKE BUTTON CODE WAS HERE ##################

részek jelölik.

A SELECT-jeinkben az approved = 1 az adminisztrátori funkció további lehetőségét hordozza magában. Tehát le lehet “tiltani” egy-egy beágyazást.

Látható a kód elején a use kulcsszavaknál, hogy használunk egynéhány modult. 🙂 Szinte gyerekjáték a Perl programozás.

Megjegyzem, hogy ez a like megvalósítás különböző webcímű (URI) weboldalanként ad lehetőséget like-olásra. Egy webcímen belül több like nem lehet. Nem a tökély a cél, csupán a megvalósíthatóság bemutatása.

A Hello World! mod_perl DBI alkalmazás

A /etc/apache2/conf-enabled/mod_perl.conf file-t az alábbiak szerint módosítottuk.

PerlModule ModPerl::Registry

Alias /perl /var/www/perl
<Directory /var/www/perl>
   AddHandler perl-script .cgi .pl
   PerlResponseHandler ModPerl::Registry
   Options +ExecCGI
</Directory>

Lehet saját handler-t is írni, de most enm tértünk ki erre a lehetőségre. 🙂

Nézzük a hello-world-dbi.cgi programocskánkat majd a beágyazását az apartman “Képek” oldalába.

#!/usr/bin/perl

use strict;
use warnings;
use DBI;
use Apache2::RequestRec ();
use Apache2::RequestUtil ();

my $r = Apache2::RequestUtil->request;

print "The referer in your HTTP-Header is: ", $ENV{'HTTP_REFERER'}, "\n";

my $dbh = DBI->connect('DBI:mysql:mylike', 'mylike', 'mylike1'
               ) || die "Could not connect to database: $DBI::errstr";

print "<br>\n";

my $results = $dbh->selectall_hashref('SELECT * FROM mylike', 'id');
foreach my $id (keys %$results) {
 print "Value of ID $id is $results->{$id}->{'referer'}\n";
}

$dbh->disconnect();

Használjuk a DBI és az új Apache2-es Request modulokat, majd lekérdezzük a HTTP_REFERER-t illetve egy select-tel belefetchelünk az adatbázisba. 🙂

Figyelem! Nagyon fontos a helyes beállítás az apache config oldalon.

A kis appunkat beágyazzuk mint widget-et az alábbi módon.

<div id="mylike"></div>
<script>$("#mylike").load("http://localhost/perl/hello-world-dbi.cgi</script>

És akkor lássuk az eredményt.

MySQL adatbázis és a Perl DBI és DBD::mysql modulok

Az adatbázis egyszerűen egyetlen egy táblából áll. Nézzük az SQL DDL kódot!

CREATE TABLE mylike (
id BIGINT UNSIGNED AUTO_INCREMENT PRIMARY KEY,
referer VARCHAR(200) NOT NULL,
counter DECIMAL(9) NOT NULL DEFAULT 0,
approved TINYINT NOT NULL DEFAULT 1,
created TIMESTAMP DEFAULT CURRENT_TIMESTAMP,
updated TIMESTAMP DEFAULT CURRENT_TIMESTAMP ON UPDATE CURRENT_TIMESTAMP
);

Pár különleges megjelölést használunk a séma létrehozásakor. Alapértékeket állítunk be a DEFAULT kódszóval, illetve AUTO_INCREMENT-tet használunk, tehát automatikus id generálást, sőt: UPDATE esetén az updated mező értéke az aktuális időpőponttal automatikusan frissül!

Parancssorból a mysql paranccsal “játszhatjuk be” az új adatbázisba új felhasználóval a DDL kódrészletet. Az adatbázis és a felhasználó létrehozása az alábbi módon történik, root-kéni futtatva a mysql parancsokat. Sima copy’n’paste. 🙂

CREATE DATABASE mylike CHARACTER SET utf8 COLLATE utf8_general_ci;
CREATE USER 'mylike'@'localhost' IDENTIFIED BY 'mylike1';
GRANT ALL PRIVILEGES ON mylike.* TO 'mylike'@'localhost';
FLUSH PRIVILEGES;

Szükség esetén a “use mylike” paranccsal jelöljük ki a használt adatbázist, amikor a táblát hozzuk létre. 🙂

Teszteljük le a létrehozott adatbázis táblánkat!

mysql> insert into mylike (referer) values ('http://localhost/valami');
Query OK, 1 row affected (0.01 sec)
mysql> select * from mylike;
+----+-------------------------+---------+----------+---------------------+---------------------+
| id | referer | counter | approved | created | updated |
+----+-------------------------+---------+----------+---------------------+---------------------+
| 1 | http://localhost/valami | 0 | 1 | 2021-01-06 15:00:35 | 2021-01-06 15:00:35 |
+----+-------------------------+---------+----------+---------------------+---------------------+
1 row in set (0.01 sec)
mysql>

A Perl megfelelő moduljait az adatbázis-eléréshez installálni szükséges. Ezek a Perl Database Interface illetve a megfelelő Perl DBI Database Driver (https://metacpan.org/pod/DBI::DBD) Ezt a Debian 10.7-ünk alatt az alábbi módon tehetjük meg.

root@gergo1:~# apt-get install libdbi-perl libdbd-mysql-perl
Reading package lists… Done
Building dependency tree
Reading state information… Done
The following packages were automatically installed and are no longer required:
libappindicator3-1 libindicator3-7
Use 'apt autoremove' to remove them.
Suggested packages:
libclone-perl libmldbm-perl libnet-daemon-perl libsql-statement-perl
The following NEW packages will be installed:
libdbd-mysql-perl libdbi-perl
0 upgraded, 2 newly installed, 0 to remove and 4 not upgraded.
Need to get 896 kB of archives.
After this operation, 2,464 kB of additional disk space will be used.
Get:1 http://httpredir.debian.org/debian buster/main amd64 libdbi-perl amd64 1.642-1+deb10u1 [775 kB]
Get:2 http://httpredir.debian.org/debian buster/main amd64 libdbd-mysql-perl amd64 4.050-2 [121 kB]
Fetched 896 kB in 1s (1,535 kB/s)
Selecting previously unselected package libdbi-perl:amd64.
(Reading database … 533195 files and directories currently installed.)
Preparing to unpack …/libdbi-perl_1.642-1+deb10u1_amd64.deb …
Unpacking libdbi-perl:amd64 (1.642-1+deb10u1) …
Selecting previously unselected package libdbd-mysql-perl:amd64.
Preparing to unpack …/libdbd-mysql-perl_4.050-2_amd64.deb …
Unpacking libdbd-mysql-perl:amd64 (4.050-2) …
Setting up libdbi-perl:amd64 (1.642-1+deb10u1) …
Setting up libdbd-mysql-perl:amd64 (4.050-2) …
Processing triggers for man-db (2.8.5-2) …
root@gergo1:~#

Megjegyzés: installálhatjuk a szükséges modulokat a Perl CPAN modulkezelőjén belül is a cpan paranccsal a konzolról, de akkor elveszítjuk a rendszerhez szállított előrecsomagolt szoftverek előnyeit. Különleges csomagokhoz valóban hasznos kiegészítő lehet a Perl CPAN modulja (https://www.cpan.org/).

A következő bejegyzésben megnézzük hogyan lehet mod_perl-ben adatbázist elérni web-ről egy Perl Hello World! kóddal. 🙂