#!/usr/bin/env perl
#
# sakai-sessions - list Sakai sessions
#
# $Id$

use warnings;
use strict;

use Getopt::Std;
use Text::CSV_XS;
use DBI;

my %opt;
getopts( '?haA:cdJl:L:mMnNQ:rRsSt:TuU:vW:X', \%opt )
 or die("error parsing options, use -h for help\n");

HELP_MESSAGE() if ( $opt{h} || $opt{'?'} );

die "spurious argument(s); use -h for help\n" if @ARGV;

validate_options();

do_it();

exit(0);

sub validate_options
{
  1 < grep { defined $opt{$_} } qw(J M Q T U)
   and die "options -J, -M, -Q, -T, and -U are incompatible\n";

  ( $opt{Q} && $opt{l} )
   and die "options -Q and -l are incompatible\n";

  my $session_list_requested =
   grep { defined $opt{$_} } qw(a c r s A L S X u W);

  foreach my $x (qw(J M Q T U))
  {
    if ( $opt{$x} && $session_list_requested )
    {
      die
"option -$x is incompatible with -a, -c, -r, -s, -u, -A, -L, -S, -W, -X\n";
    }
  }

  if ( 1 < grep { defined $opt{$_} } qw(s S X) )
  {
    die "options -s, -S, and -X are exclusive, pick at most one\n";
  }

  if ( !defined $opt{s} )
  {
    foreach my $o (qw(L S X r))
    {
      if ( defined $opt{$o} )
      {
        warn "assuming -s as -$o is specified ...\n" if $o !~ /[SX]/;
        $opt{s} = 1;
      }
    }
  }

  if ( $opt{a} && $opt{m} && !$opt{s} )
  {
    die "options -a and -m are incompatible without -s, -L, -S, or -X\n";
  }

  if ( defined( $opt{t} ) && length( $opt{t} ) != 1 )
  {
    die "the -t option takes a single character\n";
  }

  if ( defined( $opt{U} ) && !eval { qr($opt{U}) } )
  {
    my ($msg) = $@ =~ /^(.+) at /;
    die "-U argument is not a valid regular expression: $msg\n";
  }

  my @L_values = ( 'user', 'site', 'user,site', 'site,user' );

  if ( defined( $opt{L} ) && !grep { $opt{L} eq $_ } @L_values )
  {
    die "-L argument must be one of: user, site, or user,site\n";
  }

  my @W_values = ( 'only', 'too' );

  if ( defined $opt{W} && !grep { $_ eq $opt{W} } @W_values )
  {
    die "-W argument must be one of: only, or too\n";
  }
}

sub opt_m_or_M
{
  $opt{m} || $opt{M};
}

sub only_web_service_calls_wanted
{
  defined $opt{W} && $opt{W} eq 'only';
}

sub only_non_web_service_calls_wanted
{
  !defined $opt{W};
}

sub HELP_MESSAGE
{
  my $default_local_properties = default_local_properties() // 'none';

  print STDERR <<ZZ;

Usage: $0 [-Q | [-J|-M|-T|-U expr] [-l n] | [-a] [-c] [-l n] [-m] [-r] [-R] [-s|-S-|-X] [-A date] [-L [user|site|user,site]] [-W [only|too]] [-t sep] [-v] [-n]

to list Sakai sessions or issue other queries on the Sakai database.

Options:

for query processing:

  -v  Print the SQL query to standard error.
  -n  Do not execute the query, do not print any output.  Useful with -v.

for the output format:

  -t sep
      Use the given character as the output column separator;
      the default is a comma.

for query specification:

either zero or more of

  -a  List all sessions, not just the active ones.
  -c  List creation times with sites and users.
  -m  Include user memberships of sites, with current roles.
      For non-members, the current role is empty.
      Can be used with -s/-L/-S/-X; without them, just lists site members.
  -r  Include (first) user registrations to sites, with registered role and registration date.
      If no registration event is found, this field is empty.
      Note: EDIA's Invite tool does not generate such events.
      Implies -s unless -S/-X is specified.
  -R  For each user listed, list their number of 'access' and 'maintain' roles
      in sites other than My Workspace,
      unless -J is used.  (Yes, this script has grown out of hand.)
  -u  Omit session and event details.
  -s  Lists the site-specific events in each session.
  -S  Like -s, but also lists sites (and, with -r or -m, users) without any events.
  -X  Like -s, but also lists other events.
  -A date        Only lists sessions/events from the given date/time onwards.
  -L  user       Only lists the last event for each user.
  -L  site       Only lists the last event for each site.
  -L  user,site  Only lists the last event for each user and site.
      -L implies -s unless -S/-X is specified.
  -W only       Only list web service calls.  By default, they are excluded.
  -W too        Include web service calls.  By default, they are excluded.

or

  -M  List user memberships of sites, with current roles.

or

  -T  List tools used in sites with the pages they are used on.

or

  -U expr
      List URLs matching expr (a regular expression) in lesson items.
      The output has columns:

        type (5 for embedded HTML, 7 for direct URL link)
        url (the URL that was linked or embedded)
        item number on page
        page name
        site name (empty of not in any site)

     Only URLs starting with http: or https: are included.
     For type 5, each URL is reported on a separate row.

with possibly

  -N  For anything considering sites, omit user sites ('My Workspace').
  -l n
      List only the first n rows.
  -d  Sort in descending order (for sorted output only).

or

  -J  Don't list sessions; list all site join events instead,
      with the matching invite tool invites, if any.
      (Due to imperfect matching, there may be more than one.)
      (PROBLEMS:
         1) The invite tool issues realm.upd instead of realm,join,
            we include them, but they may be unjoins.
         2) The user being joined is not logged in the event!
            The user reported here is the one doing the join!
      )

with possibly

  -l n
      List only the first n rows.

or

  -Q sqlcode
      Execute the given SQL code.
      (This should probably be factored out into a separate script.)

Environment variables:

  SAKAI_PROPERTIES  The Sakai properties file to read for defaults
                    (default: $default_local_properties).

  The values in there can be overriden using

  SAKAI_USER        The MySQL user to connect as.
  SAKAI_HOST        The host to connect to.
  SAKAI_PASSWORD    The MySQL password to use.
  SAKAI_DATABASE    The MySQL database to use.
ZZ
  exit(0);
}

sub ehm
{
  $opt{v} and warn join( ' ', 'warning:', @_ ), "\n";
}

sub grep_in_file
{
  my ( $rx, $file ) = @_ or return;

  defined($file) or return;

  if ( ( open( my $fh, '<', $file ) ) )
  {
    my $match;

    while (<$fh>)
    {

      #/^$rx[^=]*=\s*(.*\S)/ and warn "$rx is $1 in $file\n";
      ($match) = /^$rx[^=]*=\s*(.*\S)/ and last;
    }

    close($fh);

    ehm("$rx not found in $file") if !defined $match;
    return $match;

  }
  else
  {
    ehm( 'cannot open file for reading:', $file );
    return;
  }
}

# SELECT query composition depending on options.
# The difference between -m and -r:
# both options imply -s, which causes events to be listed,
# but only site-specific events (i.e. for which the context is a site id),
# so we always have both a user and a site for those events; now,
# with -m, we join over the realms, limiting the events to the
# *current* site members and adding their role(s)
# (joining over site_user wouldn't produce the roles)
# but this does not tell us when membership started;
# with -r, we use the user.site.membership.add event,
# which always gets triggered when a used is added to the site,
# to construct the table (user, site, registration_date)
# listing the time the user was (*first*) added to the site,
# and then join with that table to add the registration date,
# which should not limit the events, unless the events table
# was purged in the past; with both -m and -r, we do both.
#
# The query to construct the user registration events table:
#
# SELECT MIN(event_date) AS registration_date, added_user_id, site_id
# FROM
# (
#   SELECT event_date, context AS site_id,
#   SUBSTR(ref, INSTR(ref, 'uid=')+4, INSTR(ref, ';role=')-INSTR(ref, 'uid=')-4) AS added_user_id,
#   SUBSTR(ref, INSTR(ref, 'role=')+5, INSTR(ref, ';active=')-INSTR(ref, 'role=')-5) AS added_role
#   FROM sakai_event WHERE event = "user.site.membership.add"
#   ) AS ua
# GROUP BY added_user_id, site_id;
#
# However, EDIA's Invite Tool, which we use,  does not log any such events.

# To obtain, for every site and user, the later of their creation times:
# SELECT site_id, user_id, IF (u.createdon < s.createdon, u.createdon, s.createdon) AS createdon
# FROM sakai_user AS u INNER JOIN sakai_site AS s

# auxiliary routines for SQL SELECT construction

sub paired
# given a list, returns the elements in successive pairs
{
  if ( @_ % 2 )
  {
    die "BUG: cannot pair ", scalar(@_), " elements\n";
  }

  my @list = @_;

  map { [ $list[$_], $list[ $_ + 1 ] ] } 0 .. ( $#list / 2 - 1 );
}

#sub w { warn "result: '$_[0]'\n"; $_[0] }    # for debugging only

sub nb

 # only use nonblank words/lines
{
  map { s#^(.*[^\n]|)\n*$#$1#r } grep { /\S/ } @_;
}

sub c   { join( ', ',    nb(@_) ) }    # join words with commas
sub _   { join( ' ',     nb(@_) ) }    # join words with spaces
sub AND { join( ' AND ', nb(@_) ) }

sub i

 # indent
{
  l(
    map {
      map { "  $_" }
       split( /\n/, $_ )
    } @_
  );
}

sub l

 # join lines
{
  join( '', map { s#(^.*[^\n]|)\n*$#$1\n#r } nb(@_) );
}

sub n { l( '(', i(@_), ')' ) }    # nest

sub deref

 # dereference optional array deref
{
  map { !defined($_) ? () : ref($_) eq 'ARRAY' ? @$_ : $_ } @_;
}

sub sql_select
{
  my %arg = @_;

  my @distinct = !$arg{distinct} ? () : ('DISTINCT');

  l(
    _( 'SELECT', @distinct, c( deref( $arg{columns} ) ) ),
    _( 'FROM',   c( deref( $arg{from} ) ) ),
    !$arg{where}    ? () : _( 'WHERE',    $arg{where} ),
    !$arg{group_by} ? () : _( 'GROUP BY', c( deref( $arg{group_by} ) ) ),
    !$arg{order_by}
    ? ()
    : _( 'ORDER BY', c( deref( $arg{order_by} ) ), $arg{desc} ? 'DESC' : () ),
    !defined( $arg{limit} ) ? () : _( 'LIMIT', c( deref( $arg{limit} ) ) )
  );
}

sub nested_as
{
  my ( $as, $select ) = @_;

  l( n($select), "AS $as" );
}

sub sql_join
{
  my %arg = @_;

  my @kind   = deref( $arg{kind} );
  my @tables = deref( $arg{tables} );
  my @on     = deref( $arg{on} );

  if ( $#on != $#tables - 1 && ( !@kind || $kind[0] ne 'NATURAL' ) )
  {
    die "bug! sql_join() called with wrong number of join criteria\n";
  }

  my $first = shift(@tables);

  l( $first,
    map { _( @kind, 'JOIN', $tables[$_], @on ? "ON $on[$_]" : () ) }
     0 .. $#tables );
}

sub sql_union
{
  my $first = shift(@_);

  l( $first, map { ( 'UNION', $_ ) } @_ );
}

sub sql_insert_select
{
  my %arg = @_;

  l( "INSERT INTO $arg{name}", $arg{select} );
}

sub sql_create_temporary_table
{
  my %arg = @_;

  my @columns = deref( $arg{columns} );
  die "BUG: incorrect columns specification to sql_create_temporary_table()\n"
   if @columns % 2;

  my @primkey = deref( $arg{primkey} );

  my @pk = !@primkey ? () : _( "PRIMARY KEY (", c(@primkey), ")" );

  my @index = deref( $arg{index} );
  my @ix = !@index ? () : _( "INDEX (", c(@index), ")" );

  my @pkix = ( @pk, @ix );

  my @fmt_columns = map { _( $_->[0], $_->[1] ) . ',' } paired(@columns);

  l(
    "CREATE TEMPORARY TABLE $arg{name}",
    @fmt_columns ? n(@fmt_columns) : (),
    !@pkix ? () : ( '(', i( c(@pkix) ), ')' ),
    $arg{select} ? ( 'AS', $arg{select} ) : ()
  );
}

sub sql_drop_temporary_table_if_exists
{
  "DROP TEMPORARY TABLE IF EXISTS $_[0]\n";
}

# construct the SQL statement(s) depending on the options

sub sql_for_sessions_or_members
{
  my @session =
     ( !$opt{s} && $opt{m} )
   ? ()
   : ( 'session_ip', 'session_start', 'session_end', 'session_active' );

  my @event =
   !$opt{s}
   ? ()
   : qw(event_id event_date event event_code ref context);

  my @registration =
   !$opt{r}
   ? ()
   : ('memberadd_date');

  my @role =
   !opt_m_or_M()
   ? ()
   : ('role_name');

  my @sitecreatedon_in_s =
     ( !$opt{c} || !$opt{s} )
   ? ()
   : ('s.createdon');

  my @site_in_s =
     ( !$opt{s} && !opt_m_or_M() )
   ? ()
   : ( 'title', @sitecreatedon_in_s, 'is_user', @registration, @role );

  my @realm_joined = (
    nested_as(
      'rm',
      sql_select(
        columns => [ 'SUBSTR(realm_id,7) AS site_id', 'realm_key' ],
        from    => 'sakai_realm',
        where   => 'realm_id LIKE "/site/%"'
      )
    ),
    'sakai_realm_rl_gr AS rg',
    'sakai_realm_role AS ro'
  );

  my @members = !opt_m_or_M() ? () : @realm_joined;

  my @registrations =
   !$opt{r}
   ? ()
   : (
    nested_as(
      'minua',
      sql_select(
        columns =>
         [ 'MIN(event_date) AS memberadd_date', 'user_id', 'site_id' ],
        from => nested_as(
          'ua',
          sql_select(
            columns => [
              'event_id',
              'event_date',
              'context AS site_id',
'SUBSTR(ref, INSTR(ref, "uid=")+4, INSTR(ref, ";role=")-INSTR(ref, "uid=")-4) AS user_id'
            ],
            from  => 'sakai_event',
            where => AND(
              'event = "user.site.membership.add"',
              !$opt{A} ? () : ( sprintf( 'event_date >= "%s"', $opt{A} ) )
            )
          )
        ),
        'group_by' => [ 'user_id', 'site_id' ]
      )
    )
   );

  my @on_registrations =
   !$opt{r}
   ? ()
   : ('s.site_id = minua.site_id');

  my @on_siteuserid =
     ( !$opt{m} && !$opt{r} )
   ? ()
   : ('session_user = user_id');

# with -s without -S/-X, we INNER JOIN events with sites;
# with -X, we use a LEFT JOIN;
# with -S, we use a RIGHT JOIN;
# in earlier versions, the RIGHT JOIN was found to be too slow
# unless we use temporary tables for the joined parts;
# therefore, an option was added to use them (-D),
# but right now, -S is fast enough, -D broke, and was removed;
# we'd also like to have an option to do a FULL OUTER JOIN,
# but MySQL doesn't support it, and when emulating it using
# a LEFT JOIN UNION RIGHT JOIN, the UNIONed parts must be wrapped in SELECTs;
# the result runs for minutes, after which we get
# DBD::mysql::st execute failed: Incorrect key file for table '/tmp/#sql_4be_4.MYI'; try to repair it at /home/sakai/bin/sakai-sessions line 387.
# so that UNION just isn't feasible,
# and I haven't found a good workaround yet
# (adding dummy rows to the right part, then doing a LEFT JOIN, would probably work)

  my $session_AW = (
    $opt{A}
     || only_web_service_calls_wanted()
     || only_non_web_service_calls_wanted() )
   ? nested_as(
    'n',
    sql_select(
      columns => '*',
      from    => 'sakai_session',
      where   => AND(
        ( $opt{A} ? ( sprintf( 'session_start >= "%s"', $opt{A} ) ) : () ),
        (
          only_web_service_calls_wanted()
          ? ('session_user_agent LIKE "Sakai%.jws%"')
          : ()
        ),
        (
          only_non_web_service_calls_wanted()
          ? ('NOT session_user_agent LIKE "Sakai%.jws%"')
          : ()
        )
      )
    )
   )
   : 'sakai_session AS n';

  my $session_w_event = sql_join(
    kind   => 'NATURAL',
    tables => [ $session_AW, 'sakai_event AS e' ],
  );

  my $session_user = ( $opt{m} || $opt{r} ) ? 's.user_id' : 'session_user';

# when available, use s.user_id instead of session_user, or -S will be the same as -s

  my $site_w_mr =
   ( !opt_m_or_M() && !$opt{r} )
   ? 'sakai_site AS s'
   : nested_as(
    's',
    sql_select(
      columns => [ 'site_id', 'user_id', @site_in_s ],
      from    => sql_join(
        kind   => 'NATURAL',
        tables => [ 'sakai_site AS s', @members, @registrations ]
      ),
      !$opt{N} ? () : ( where => 'is_user = 0' ),
    )
   );

  my $session_j_site = sub {
    sql_join(
      kind   => $_[0],
      tables => [ $session_w_event, $site_w_mr ],
      on     => AND( 'context = site_id', @on_siteuserid )
    );
  };

  my $session_w_site =
     ( $opt{m} && !$opt{s} ) ? $site_w_mr
   : $opt{S} ? &$session_j_site('RIGHT')
   : $opt{X} ? &$session_j_site('LEFT')
   : $opt{s} ? &$session_j_site('INNER')
   : $session_AW;

  my @preparations;

  if ( $opt{L} )
  {

    # with -L, take only the last event for the user;
    # MySQL lacks LAST() and MySQL < 8.0 lacks WITH,
    # so we must do a self-join with one half taking the MAX(event_id);
    # computing the table on which to do the self-join can be expensive,
    # so we store it in a temporary in-memory table;
    # TO DO: ought to be in a transaction

    my $tmp_table_name1 = 'ss_site_event';
    my $tmp_table_name2 = 'ss_last_site_event_for_user';
    # need to use another table to avoid "Can't re-open table" error

    #push( @preparations, sql_drop_temporary_table_if_exists($tmp_table_name1) );
    # superfluous

    my $session_w_site_select = sql_select(
      columns => [ $session_user, @session, @event, 'site_id', @site_in_s ],
      from    => $session_w_site,
      where   => AND(
        ( $opt{a} || !@session ) ? () : ('session_active = 1'),
        ( !$opt{A} || !$opt{s} )
        ? ()
        : ( sprintf( 'event_date >= "%s"', $opt{A} ) )
      )
    );

    push(
      @preparations,
      sql_create_temporary_table(
        name    => $tmp_table_name1,
        primkey => [ 'event_id', $session_user, 'site_id' ],
        select  => $session_w_site_select
         # on MySQL 5.5, this fails with a read-only user! even with limit => 0;
         # CREATE TEMPORARY TABLE doesn't allow you to actually use the resulting table
         # this was fixed in 5.6:
         # https://mariadb.atlassian.net/browse/MDEV-4818
      )
    );

    my @group_by = (
      $opt{L} =~ /user/ ? ($session_user) : (),
      $opt{L} =~ /site/ ? ('site_id')     : ()
    );

    #push( @preparations, sql_drop_temporary_table_if_exists($tmp_table_name2) );
    # superfluous

    push(
      @preparations,
      sql_create_temporary_table(
        name    => $tmp_table_name2,
        primkey => [ 'event_id', @group_by ],
        select  => sql_select(
          columns  => [ 'MAX(event_id) AS event_id', @group_by ],
          group_by => [@group_by],
          from     => $tmp_table_name1,
        )
      )
    );

    $session_w_site = sql_join(
      kind   => 'NATURAL',
      tables => [ $tmp_table_name1, $tmp_table_name2 ]
    );
  }

  my @role_name_counts =
   map { sprintf( 'SUM(role_name = "%s") AS nr_%s', $_, $_ ) }
   qw(access maintain);

  my $sakai_user_as_u =
   !$opt{'R'}
   ? 'sakai_user AS u'
   : nested_as(
    'u',
    sql_select(
      columns => [qw(u.user_id email createdon nr_access nr_maintain)],
      from    => sql_join(
        kind   => 'LEFT',
        on     => 'u.user_id = rm.user_id',
        tables => [
          'sakai_user AS u',
          nested_as(
            'rm',
            sql_select(
              columns => [ 'user_id', @role_name_counts ],
              from    => sql_join(
                kind   => 'NATURAL',
                tables => [ @realm_joined, 'sakai_site AS s' ]
              ),
              where    => 'is_user = 0',
              group_by => 'user_id'
            )
          )
        ]
      )
    )
   );

  my $session_w_user = sql_join(
    kind   => 'INNER',
    tables => [ $session_w_site, $sakai_user_as_u, 'sakai_user_id_map AS m' ],
    on => [ "$session_user = u.user_id", 'u.user_id = m.user_id' ]
  );

  my @sitecreatedon_out =
     ( !$opt{c} || !$opt{s} )
   ? ()
   : ('s.createdon AS site_createdon');

  my @site_out =
     ( !$opt{s} && !opt_m_or_M() )
   ? ()
   : ( 'title AS site_name', @sitecreatedon_out, @registration );

  my @usercreatedon =
   !$opt{c}
   ? ()
   : ('u.createdon AS user_createdon');

  my @user_out = ( 'eid AS user_name', 'email', @usercreatedon, @role );

  my @role_count_out =
   !$opt{'R'}
   ? ()
   : ( 'nr_access', 'nr_maintain' );

  my $select_for_M = sql_select(
    columns => [ @site_out, @user_out, @role_count_out ],
    from    => sql_join(
      kind   => 'NATURAL',
      tables => [ $sakai_user_as_u, 'sakai_user_id_map AS m', $site_w_mr ]
    ),
    order_by => [qw(is_user title user_name)],
    desc     => defined( $opt{d} ),
    !$opt{N} ? () : ( where => 'is_user = 0' ),
    !$opt{l} ? () : ( limit => $opt{l} )
  );

  my $select_for_non_M = sql_select(
    distinct => !!$opt{u},
    columns  => [
      $opt{u} ? () : ( @session, @event ),
      @site_out, @user_out, @role_count_out
    ],
    from => $session_w_user,
    @event     ? ( order_by => 'event_id',      desc => defined( $opt{d} ) )
    : @session ? ( order_by => 'session_start', desc => defined( $opt{d} ) )
    : (),
    where => AND(
      ( $opt{a} || !@session ) ? () : ('session_active = 1'),
      ( !$opt{A} || !$opt{s} ) ? ()
      : ( sprintf( 'event_date >= "%s"', $opt{A} ) )
    ),
    !$opt{l} ? () : ( limit => $opt{l} )
  );

  ( @preparations, $opt{M} ? $select_for_M : $select_for_non_M );
}

sub sql_for_joins

 # list all realm.join events, joined with
 #  - the invite.invite event(s), if any
 #  - site info of the site in question, if any (may have been deleted)
 #  - user info of the invited user, if any (may have been deleted)
{
  my $invites = sql_select(
    columns => [ 'event_date AS invite_date', 'session_id' ],
    from    => 'sakai_event',
    where   => AND(
      'event = "invite.invite"',
      !$opt{A} ? () : ( sprintf( 'event_date >= "%s"', $opt{A} ) )
    )
  );

  my $realm_join_events = sql_select(
    columns => [
      'event_id',   'event_date',
      'session_id', 'SUBSTR(ref, 8) AS realm_id',
      'SUBSTR(context, 2) AS user_id'
    ],
    from  => 'sakai_event',
    where => AND(
      '(event = "realm.join" OR event = "realm.upd")',

# it should be realm.join, but at least in 10.4 is actually realm.upd, which can be an unjoin, too :-(
      'ref LIKE "/realm/%"',
      'context LIKE "~%"',
      !$opt{A} ? () : ( sprintf( 'event_date >= "%s"', $opt{A} ) )
    ),
    !$opt{l} ? () : ( limit => $opt{l} )
  );

  my $site_realms = sql_select(
    columns => [ 'realm_id', 'SUBSTR(realm_id, 7) AS site_id' ],
    from    => 'sakai_realm',
    where   => 'realm_id LIKE "/site/%"'
  );

  sql_select(
    columns =>
     [ 'event_date', 'invite_date', 'user_id', 'email', 'site_id', 'title' ],
    from => sql_join(
      kind   => 'NATURAL LEFT',
      tables => [
        nested_as( 'e', $realm_join_events ),
        'sakai_user',
        nested_as( 'r', $site_realms ),

        #'sakai_site',  # nope, won't join correctly
        nested_as(
          's',
          sql_select(
            columns => [ 'site_id', 'title' ],
            from    => 'sakai_site',
            !$opt{N} ? () : ( where => 'is_user = 0' )
          )
        ),
        nested_as( 'i', $invites )
      ]
    ),
    order_by => 'event_id',
    desc     => defined( $opt{d} ),
    !$opt{l} ? () : ( limit => $opt{l} )
  );
}

sub sql_for_tool_list
{
  sql_select(
    columns => [
      'registration as tool_registration',
      't.title as tool_title',
      'p.title as page_title',
      'p.site_order as page_number',
      's.title as site_title',
      'type as site_type'
    ],
    from => sql_join(
      tables =>
       [ 'sakai_site_tool as t', 'sakai_site_page as p', 'sakai_site as s' ],
      on => [ 't.page_id = p.page_id', 'p.site_id = s.site_id' ]
    ),
    order_by => [qw(is_user site_title page_number)],
    desc     => defined( $opt{d} ),
    !$opt{N} ? () : ( where => 'is_user = 0' ),
    !$opt{l} ? () : ( limit => $opt{l} )
  );
}

sub sql_for_item_urls
{
  my $U = $opt{U};

  # escape the escapes for MySQL
  $U =~ s#\\#$&$&#g;
  my $url_rx = '^https?://.*' . $U;

  sql_select(
    columns => [
      's.title as site_name',
      'p.title as page_name',
      'sequence as item_nr',
      'itemtype as item_type',
      'url'
    ],
    from => sql_join(
      kind   => 'LEFT',
      tables => [
        nested_as(
          'iu',
          sql_union(
            # type 7 is a direct hyperlink, listed in the 'name' column
            sql_select(
              columns =>
               [ 'pageId', 'sequence', 'i.type as itemtype', 'name as url' ],
              from  => 'lesson_builder_items as i',
              where => AND( 'type = 7', 'name REGEXP "' . $url_rx . '"' )
            ),

            # type 5 is embedded HTML, which may contain hyperlinks;
            # MySQL lacks the primitives to return matches for a REGEXP,
            # so we return all html and postprocess it in Perl later :-(
            sql_select(
              columns =>
               [ 'pageId', 'sequence', 'i.type as itemtype', 'html as url' ],
              from => 'lesson_builder_items as i',

              #where => AND( 'type = 5', 'html REGEXP "' . $url_rx . '"' )
              where => 'type = 5'
            )
          )
        ),
        'lesson_builder_pages as p',
        'sakai_site as s'
      ],
      on => [ 'iu.pageId = p.pageId', 'p.siteId = s.site_id' ]
    ),
    order_by => [qw(s.title p.title sequence item_nr)],
    desc     => defined( $opt{d} ),
    !$opt{N} ? () : ( where => 'is_user = 0' ),
    !$opt{l} ? () : ( limit => $opt{l} )
  );
}

sub sub_urls_in
{

  # returns a sub; the value of $opt{U} is not yet known, so pass it!
  my $opt_U = $_[0];

  die "bug! sub_urls_in called when it shouldn't be\n" if !defined $opt_U;

  my $U_rx = qr(https?://.*$opt_U);

  my $link2urls = sub

   # given ( 'a', 'href' => $url, ... ) returns ( $url, ... )
  {
    @_[ grep { !( $_ % 2 ) } ( 0 .. $#_ ) ];
  };

  my $url_rx = qr(https?://[^"'<]*);

  my $urls_in_html = sub {

    # for code to compare this with HTML::LinkExtor-based results,
    # see r514. this strictly gets more links, at least on the present contents
    my ($html) = @_;

    grep { /$U_rx/ }
     map { s/\s*$//; s/&amp;/&/g; s/&showplayer=.*//; $_ } $html =~ /$url_rx/g;
  };

  sub

# a very specific routine to postprocess a row in -U results;
# for type 5, we return the fill HTML text, and we want to return each URL in it,
# so we return a separate row for each
  {
    my ( $sitename, $pagename, $itemnr, $itemtype, $url ) = @{ $_[0] };

    if ( $itemtype == 5 )
    {

      # $url is actually the full HTML text
      map { [ $sitename, $pagename, $itemnr, $itemtype, $_ ] }
       &$urls_in_html($url);
    }
    else
    {
      $_[0];
    }
   }
}

sub as_utf8
{
  my @r = @_;
  utf8::upgrade($_) for @r;
  @r;
}

sub default_local_properties
{
  foreach
   my $d ( '/home/tomcat8s11/tomcat8', '/var/lib/tomcat8', '/var/lib/tomcat7' )
  {
    my $f = "$d/sakai/local.properties";

    if ( -e $f )
    {
      return $f;
    }
  }

  undef;
}

sub do_it
{
  my $csvh = new Text::CSV_XS( { eol => $/, sep_char => ( $opt{t} // ',' ) } )
   or die "cannot create CSV writer: $@\n";

  binmode STDOUT, ':utf8';

  my $local_properties = $ENV{SAKAI_PROPERTIES} // default_local_properties()
   // die
"cannot find the local.properties file to use, please set SAKAI_PROPERTIES to point to it\n";

  my $username = $ENV{SAKAI_USER}
   // grep_in_file( 'username', $local_properties ) // 'sakai';
  my $password = $ENV{SAKAI_PASSWORD}
   // grep_in_file( 'password', $local_properties ) // 'Daisen kofun';
  my $url = grep_in_file( 'url', $local_properties )
   // 'jdbc:mysql://127.0.0.1:3306/sakai293';
  my $hostname = $ENV{SAKAI_HOST}
   // ( $url =~ m#://(\d.]+)# ? $1 : 'localhost' );
  my $database = $ENV{SAKAI_DATABASE}
   // ( $url =~ m#.*/([^?/]++)# ? $1 : 'sakai293' );

  my @stmt =
     $opt{Q} ? $opt{Q}
   : $opt{U} ? sql_for_item_urls()
   : $opt{J} ? sql_for_joins()
   : $opt{T} ? sql_for_tool_list()
   :           sql_for_sessions_or_members();

  if ( $opt{v} )
  {
    my $pressing = -f $local_properties ? 'present' : 'missing';

    warn "propfile: $local_properties ($pressing)\n";
    warn "username: $username\n";
    warn "hostname: $hostname\n";
    warn "database: $database\n";
    warn "db_query:\n", join( ";\n", @stmt ), "\n";
  }

  if ( $opt{n} )
  {

    # done!
    exit(0);
  }

  my $dbh = DBI->connect( "dbi:mysql:$database;hostname=$hostname",
    $username, $password,
    { RaiseError => 0, AutoCommit => 0, mysql_enable_utf8 => 1 } )
   or die "cannot connect to Sakai database: $@\n";

  foreach my $stmt (@stmt)
  {
    my $sth = $dbh->prepare( $stmt =~ s/\n/ /gr )
     or die "cannot prepare SQL query: $@\n";

    if ( !$sth->execute() )
    {

      # already issues a warning message
      next;
    }

    if ( !$sth->{NUM_OF_FIELDS} )

     # e.g. an UPDATE statement, see DBD::mysql
    {
      $dbh->commit();
    }
    else
    {
      # print the header in uppercase
      $csvh->print( *STDOUT, [ map { uc($_) } @{ $sth->{NAME} } ] );

      my @result = @{ $sth->fetchall_arrayref() };

      if ( defined( $opt{U} ) )
      {

        # extract URLs from HTML contents
        my $urls_in = sub_urls_in( $opt{U} );
        @result = map { &$urls_in($_) } @result;
      }

      # print the contents
      $csvh->print( *STDOUT, [ as_utf8( map { $_ // '' } @$_ ) ] ) for @result;
    }

    $sth->finish();
  }

  $dbh->disconnect();
}