path: root/perl_checker.src/parser_helper.ml

open Types
open Common
open Printf

let bpos = -1, -1

let raw_pos2pos(a, b) = !Info.current_file, a, b
let raw_pos_range { pos = (a1, b1) } { pos = (a2, b2) } = (if a1 = -1 then a2 else a1), (if b2 = -1 then b1 else b2)
let pos_range esp1 esp2 = raw_pos2pos (raw_pos_range esp1 esp2)
let get_pos pesp = raw_pos2pos pesp.pos
let get_pos_start { pos = (start, _) } = start
let get_pos_end { pos = (_, end_) } = end_
let var_dollar_ pos = Deref(I_scalar, Ident(None, "_", pos))
let var_STDOUT = Deref(I_star, Ident(None, "STDOUT", raw_pos2pos bpos))

let new_any mcontext any spaces pos = { mcontext = mcontext ; any = any ; spaces = spaces ; pos = pos }
let new_any_ any spaces pos = new_any M_unknown any spaces pos
let new_esp mcontext e esp_start esp_end = new_any mcontext e esp_start.spaces (raw_pos_range esp_start esp_end)
let new_1esp e esp = new_any esp.mcontext e esp.spaces esp.pos
let new_pesp mcontext prio e esp_start esp_end = new_any mcontext { priority = prio ; expr = e } esp_start.spaces (raw_pos_range esp_start esp_end)
let new_1pesp prio e esp = new_any esp.mcontext { priority = prio ; expr = e } esp.spaces esp.pos
let default_esp e = new_any M_unknown e Space_none bpos
let default_pesp prio e = new_any M_unknown { priority = prio ; expr = e } Space_none bpos

let split_name_or_fq_name full_ident =
  match split_at2 ':'':' full_ident with
  | [] -> internal_error "split_ident"
  | [ident] -> None, ident
  | l ->
      let fql, name = split_last l in
      let fq = String.concat "::" fql in
      Some fq, name

let is_var_dollar_ = function
  | Deref(I_scalar, Ident(None, "_", _)) -> true
  | _ -> false
let is_var_number_match = function
  | Deref(I_scalar, Ident(None, s, _)) -> String.length s = 1 && s.[0] <> '0' && char_is_number s.[0]
  | _ -> false

let non_scalar_context context = context = I_hash || context = I_array
let is_scalar_context context = context = I_scalar
  
let rec is_not_a_scalar = function
  | Deref_with(_, context, _, _)
  | Deref(context, _) -> non_scalar_context context
  | List []
  | List(_ :: _ :: _) -> true
  | Call(Deref(I_func, Ident(None, "map", _)), _)
  | Call(Deref(I_func, Ident(None, "grep", _)), _) -> true
  | Call_op("?:", [ _cond ; a; b ], _) -> is_not_a_scalar a || is_not_a_scalar b
  | _ -> false
  
let is_not_a_scalar_or_array = function
  | Deref_with(_, context, _, _)
  | Deref(context, _) -> context = I_hash
  | List []
  | List(_ :: _ :: _) -> true
  | _ -> false

let is_a_scalar = function
  | Ref _
  | Num _
  | Raw_string _
  | String _ -> true
  | My_our(_, [ context, _ ], _)
  | Deref_with(_, context, _, _)
  | Deref(context, _) -> is_scalar_context context
  | _ -> false

let is_a_string = function
  | String _ | Raw_string _ -> true
  | _ -> false

let is_parenthesized = function
  | List[]
  | List[List _] -> true
  | _ -> false

let un_parenthesize = function
  | List[List[e]] -> e
  | List[e] -> e
  | _ -> internal_error "un_parenthesize"

let rec un_parenthesize_full = function
  | List[e] -> un_parenthesize_full e
  | e -> e

let is_always_true = function
  | Num(n, _) -> float_of_string n <> 0.
  | Raw_string(s, _) -> s <> ""
  | String(l, _) -> l <> []
  | Ref _ -> true
  | _ -> false

let is_always_false = function
  | Num(n, _) -> float_of_string n = 0.
  | Raw_string(s, _) -> s = ""
  | String(l, _) -> l = []
  | List [] -> true
  | Ident(None, "undef", _) -> true
  | _ -> false

let not_complex e =
  if is_parenthesized e then true else
  let rec not_complex_ op = function
    | Call_op("?:", _, _) -> false
    | Call_op(op', l, _) -> op <> op' && List.for_all (not_complex_ op') l
    | e -> not (is_parenthesized e)
  in not_complex_ "" (un_parenthesize_full e)

let not_simple = function
  | Num _ | Ident _ | Deref(_, Ident _) -> false
  | _ -> true

let string_of_Ident = function
  | Ident(None, s, _) -> s
  | Ident(Some fq, s, _) -> fq ^ "::" ^ s
  | _ -> internal_error "string_of_Ident"
let context2s = function
  | I_scalar -> "$"
  | I_hash -> "%"
  | I_array -> "@"
  | I_func -> "&"
  | I_raw -> ""
  | I_star -> "*"
let variable2s(context, ident) = context2s context ^ ident

let rec is_same_fromparser a b =
  match a, b with
  | Undef, Undef -> true
  | Ident(fq1, s1, _), Ident(fq2, s2, _) -> fq1 = fq2 && s1 = s2
  | Num(s1, _), Num(s2, _) 
  | Raw_string(s1, _), Raw_string(s2, _) -> s1 = s2

  | String(l1, _), String(l2, _) ->
      for_all2_ (fun (s1, e1) (s2, e2) -> s1 = s2 && is_same_fromparser e1 e2) l1 l2

  | Ref(c1, e1), Ref(c2, e2)
  | Deref(c1, e1), Deref(c2, e2) -> c1 = c2 && is_same_fromparser e1 e2

  | Deref_with(c1, c_1, e1, e_1), Deref_with(c2, c_2, e2, e_2) -> c1 = c2 && c_1 = c_2 && is_same_fromparser e1 e2 && is_same_fromparser e_1 e_2

  | Diamond(None), Diamond(None) -> true
  | Diamond(Some e1), Diamond(Some e2) -> is_same_fromparser e1 e2

  | List(l1), List(l2) -> for_all2_ is_same_fromparser l1 l2

  | Call_op(op1, l1, _), Call_op(op2, l2, _) -> op1 = op2 && for_all2_ is_same_fromparser l1 l2
  | Call(e1, l1), Call(e2, l2) -> is_same_fromparser e1 e2 && for_all2_ is_same_fromparser l1 l2

  | Method_call(e1, m1, l1), Method_call(e2, m2, l2) ->
      is_same_fromparser e1 e2 && is_same_fromparser m1 m2 && for_all2_ is_same_fromparser l1 l2

  | _ -> false

let from_scalar esp =
  match esp.any with
  | Deref(I_scalar, ident) -> ident
  | _ -> internal_error "from_scalar"

let from_array esp =
  match esp.any with
  | Deref(I_array, ident) -> ident
  | _ -> internal_error "from_array"

let msg_with_rawpos (start, end_) msg = Info.pos2sfull_current start end_ ^ msg
let die_with_rawpos raw_pos msg = failwith (msg_with_rawpos raw_pos msg)
let warn raw_pos msg = print_endline_flush (msg_with_rawpos raw_pos msg)

let die_rule msg = die_with_rawpos (Parsing.symbol_start(), Parsing.symbol_end()) msg
let warn_rule msg = warn (Parsing.symbol_start(), Parsing.symbol_end()) msg
let debug msg = if true then print_endline_flush msg

let warn_verb pos msg = if not !Flags.quiet then warn (pos, pos) msg
let warn_too_many_space start = warn_verb start "you should have only one space here"
let warn_no_space	start = warn_verb start "you should have a space here"
let warn_cr		start = warn_verb start "you should not have a carriage-return (\\n) here"
let warn_space		start = warn_verb start "you should not have a space here"

let rec prio_less = function
  | P_none, _ | _, P_none -> internal_error "prio_less"

  | P_paren_wanted prio1, prio2
  | prio1, P_paren_wanted prio2 -> prio_less(prio1, prio2)

  | P_ternary, P_or -> false
  | P_ternary, P_and -> false

  | _, P_loose -> true
  | P_loose, _ -> false
  | _, P_or -> true
  | P_or, _ -> false

  | _, P_and -> true
  | P_and, _ -> false
  | _, P_call_no_paren -> true
  | P_call_no_paren, _ -> false
  | _, P_comma -> true
  | P_comma, _ -> false
  | _, P_assign -> true
  | P_assign, _ -> false
  | _, P_ternary -> true
  | P_ternary, _ -> false

  | _, P_tight_or -> true
  | P_tight_or, _ -> false
  | _, P_tight_and -> true
  | P_tight_and, _ -> false

  | P_bit, P_bit -> true
  | P_bit, _ -> false

  | _, P_expr -> true
  | P_expr, _ -> false

  | _, P_eq -> true
  | P_eq, _ -> false
  | _, P_cmp -> true
  | P_cmp, _ -> false
  | _, P_add -> true
  | P_add, _ -> false
  | _, P_mul -> true
  | P_mul, _ -> false
  | _, P_tight -> true
  | P_tight, _ -> false

  | _, P_paren _ -> true
  | P_paren _, _ -> true
  | P_tok, _ -> true

let prio_lo_check pri_out pri_in pos expr =
  if prio_less(pri_in, pri_out) then
    (match pri_in with
    | P_paren (P_paren_wanted _) -> ()
    | P_paren pri_in' ->
	if pri_in' <> pri_out && 
	   prio_less(pri_in', pri_out) && not_complex (un_parenthesize expr) then 
	  warn pos "unneeded parentheses"
    | _ -> ())
  else 
    (match expr with
    | Call_op ("print", [Deref (I_star, Ident (None, "STDOUT", _)); Deref(I_scalar, ident)], _) -> 
	 warn pos (sprintf "use parentheses: replace \"print $%s ...\" with \"print($%s ...)\"" (string_of_Ident ident) (string_of_Ident ident))
    | _ -> warn pos "missing parentheses (needed for clarity)")

let prio_lo pri_out in_ = prio_lo_check pri_out in_.any.priority in_.pos in_.any.expr ; in_.any.expr

let prio_lo_after pri_out in_ =
  if in_.any.priority = P_call_no_paren then in_.any.expr else prio_lo pri_out in_

let prio_lo_concat esp = prio_lo P_mul { esp with any = { esp.any with priority = P_paren_wanted esp.any.priority } }

let hash_ref esp = Ref(I_hash, prio_lo P_loose esp)

let sp_0 esp =
  match esp.spaces with
  | Space_none -> ()
  | Space_0 -> ()
  | Space_1
  | Space_n -> warn_space (get_pos_start esp)
  | Space_cr 
	    askdisplay => sub { print "Please enter the X11 display to perform the install on ? "; $o->{display} = chomp_(scalar(<STDIN>)) },
	    security  => sub { $o->{security} = $v },
	    noauto    => sub { $::noauto = 1 },
	    testing   => sub { $::testing = 1 },
	    patch     => sub { $patch = 1 },
	    defcfg    => sub { $cfg = $v },
	    recovery  => sub { $::recovery = 1 },
	    restore   => sub { $::restore = 1 },
	    newt      => sub { $o->{interactive} = "newt" },
	    text      => sub { $o->{interactive} = "newt" },
	    stdio     => sub { $o->{interactive} = "stdio" },
	    kickstart => sub { $::auto_install = $v },
	    uml_install => sub { $::uml_install = 1 },
	    auto_install => sub { $::auto_install = $v },
	    simple_themes => sub { $o->{simple_themes} = 1 },
	    theme     => sub { $o->{theme} = $v },
	    doc       => sub { $o->{doc} = 1 },  #- will be used to know that we're running for the doc team,
	                                         #- e.g. we want screenshots with a good B&W contrast
	    useless_thing_accepted => sub { $o->{useless_thing_accepted} = 1 },
	    alawindows => sub { $o->{security} = 0; $o->{partitioning}{clearall} = 1; $o->{bootloader}{crushMbr} = 1 },
	    fdisk => sub { $o->{partitioning}{fdisk} = 1 },
	    nomouseprobe => sub { $o->{nomouseprobe} = $v },
	    updatemodules => sub { $o->{updatemodules} = 1 },
	    move  => sub { $::move = 1 },
	    globetrotter  => sub { $::move = 1; $::globetrotter = 1 },
	}}{lc $n}; &$f if $f;
    } %cmdline;

    if ($::testing) {
	$ENV{SHARE_PATH} ||= "/export/install/stage2/live/usr/share";
	$ENV{SHARE_PATH} = "/usr/share" if !-e $ENV{SHARE_PATH};
    } else {
	$ENV{SHARE_PATH} ||= "/usr/share";
    }

    undef $::auto_install if $cfg;
    if (!$::testing) {
	unlink $_ foreach "/modules/modules.mar", "/sbin/stage1";
    }

    log::openLog(($::testing || $o->{localInstall}) && 'debug.log');
    log::l("second stage install running (", any::drakx_version(), ")");

    eval { fs::mount('none', '/sys', 'sysfs', 1) };

    if ($::move) {
        require move;
        move::init($o);
    }

    cp_f(glob('/stage1/tmp/*'), '/tmp');

    #- free up stage1 memory
    eval { fs::umount($_) } foreach qw(/stage1/proc/bus/usb /stage1/proc /stage1);

    $o->{prefix} = $::prefix = $::testing ? "/tmp/test-perl-install" : $::move ? "" : "/mnt";
    mkdir $o->{prefix}, 0755;
    devices::make("/dev/zero"); #- needed by ddcxinfos

    #-  make sure we don't pick up any gunk from the outside world
    my $remote_path = "$o->{prefix}/sbin:$o->{prefix}/bin:$o->{prefix}/usr/sbin:$o->{prefix}/usr/bin:$o->{prefix}/usr/X11R6/bin";
    $ENV{PATH} = "/usr/bin:/bin:/sbin:/usr/sbin:/usr/X11R6/bin:$remote_path";

    eval { spawnShell() };

    modules::load_dependencies(($::testing ? ".." : "") . "/modules/modules.dep");
    require modules::any_conf;
    require modules::modules_conf;
    $o->{modules_conf} = modules::modules_conf::read(modules::any_conf::vnew(), '/tmp/modules.conf');
    modules::read_already_loaded($o->{modules_conf});

    #- done before auto_install is called to allow the -IP feature on auto_install file name
    if (-e '/tmp/network') {
	require network::network;
	#- get stage1 network configuration if any.
	log::l('found /tmp/network');
	$o->{netc} ||= {};
	add2hash($o->{netc}, network::network::read_conf('/tmp/network'));
	if (my ($file) = glob_('/tmp/ifcfg-*')) {
	    log::l("found network config file $file");
	    my $l = network::network::read_interface_conf($file);
	    $o->{intf}{$l->{DEVICE}} ||= $l;
	}
	if (-e '/etc/resolv.conf') {
	    my $file = '/etc/resolv.conf';
	    log::l("found network config file $file");
	    add2hash($o->{netc}, network::network::read_resolv_conf($file));
	}
    }

    #- done after module dependencies are loaded for "vfat depends on fat"
    if ($::auto_install) {
	if ($::auto_install =~ /-IP(\.pl)?$/) {
	    my ($ip) = cat_('/tmp/stage1.log') =~ /configuring device (?!lo)\S+ ip: (\S+)/;
	    my $normalized_ip = join('', map { sprintf "%02X", $_ } split('\.', $ip)); 
	    $::auto_install =~ s/-IP(\.pl)?$/-$normalized_ip$1/;
	}
	require install_steps_auto_install;
	eval { $o = $::o = install_any::loadO($o, $::auto_install) };
	if ($@) {
	    if ($o->{useless_thing_accepted}) { #- Pixel's hack to be able to fail through
		log::l("error using auto_install, continuing");
		undef $::auto_install;
	    } else {
		install_steps_auto_install_non_interactive::errorInStep($o, "Error using auto_install\n" . formatError($@));
	    }
	} else {
	    log::l("auto install config file loaded successfully");

	    #- normalize for people not using our special scheme
	    foreach (@{$o->{manualFstab} || []}) {
		$_->{device} =~ s!^/dev/!!;
	    }
	}
    }
    $o->{interactive} ||= 'gtk' if !$::auto_install;
 
    if ($o->{interactive} eq "gtk" && availableMemory() < 22 * 1024) {
 	log::l("switching to newt install cuz not enough memory");
 	$o->{interactive} = "newt";
    }

    if (my ($s) = cat_("/proc/cmdline") =~ /brltty=(\S*)/) {
	my ($driver, $device, $table) = split(',', $s);
	$table = "text.$table.tbl" if $table !~ /\.tbl$/;
	log::l("brltty option $driver $device $table");
	$o->{brltty} = { driver => $driver, device => $device, table => $table };
	$o->{interactive} = 'newt';
	$o->{nomouseprobe} = 1;
    }

    # perl_checker: require install_steps_gtk
    # perl_checker: require install_steps_newt
    # perl_checker: require install_steps_stdio
    require "install_steps_$o->{interactive}.pm" if $o->{interactive};

    #- needed before accessing floppy (in case of usb floppy)
    modules::load_category($o->{modules_conf}, 'bus/usb'); 

    #- oem patch should be read before to still allow patch or defcfg.
    eval { $o = $::o = install_any::loadO($o, "install/patch-oem.pl"); log::l("successfully read oem patch") };
    #- recovery mode should be read early to allow default parameter to be taken.
    eval { $o = $::o = install_any::loadO($o, "install/recovery.cfg"); log::l("successfully read recovery") } if $::recovery;
    $@ and $::recovery = 0; #- avoid keeping recovery if there was a problem reading the recovery.cfg file.
    #- patch should be read after defcfg in order to take precedance.
    eval { $o = $::o = install_any::loadO($o, $cfg); log::l("successfully read default configuration: $cfg") } if $cfg;
    eval { $o = $::o = install_any::loadO($o, "patch"); log::l("successfully read patch") } if $patch;

    eval { modules::load("af_packet") };

    require harddrake::sound;
    harddrake::sound::configure_sound_slots($o->{modules_conf});

    #- need to be after oo-izing $o
    if ($o->{brltty}) {
	symlink "/tmp/stage2/$_", $_ foreach "/etc/brltty";
	if (common::usingRamdisk()) {
	    install_any::remove_unused(0);
	    mkdir '/tmp/stage2/etc/brltty';
	    mkdir '/lib/brltty';
	    foreach ($o->{brltty}{table}, "brltty-$o->{brltty}{driver}.hlp") {
		install_any::getAndSaveFile("/etc/brltty/$_") if $_;
	    }
	    install_any::getAndSaveFile("/lib/brltty/libbrlttyb$o->{brltty}{driver}.so") or do {
		local $| = 1;
		print("Braille driver $o->{brltty}{driver} for BRLTTY was not found.\n",
		      "Press ENTER to continue.\n\a");
		<STDIN>;
	    };
	    install_any::getAndSaveFile("/usr/bin/brltty");
	    chmod 0755, "/usr/bin/brltty";
	}
	eval { modules::load("serial") };
	devices::make($_) foreach $o->{brltty}{device} ? $o->{brltty}{device} : qw(ttyS0 ttyS1);
	devices::make("vcsa");
	run_program::run("brltty");
    }

    #- needed very early for install_steps_gtk
    if (!$::testing) {
	eval { $o->{mouse} = mouse::detect($o->{modules_conf}) } if !$o->{mouse} && !$o->{nomouseprobe};
	mouse::load_modules($o->{mouse});
    }

    $o->{locale}{lang} = lang::set($o->{locale}) if $o->{locale}{lang} ne 'en_US' && !$::move; #- mainly for defcfg

    start_i810fb();

    $o->{allowFB} = listlength(cat_("/proc/fb"));

    if (!$::move && !$::testing) {
	my $VERSION = cat__(install_any::getFile("VERSION")) or do { print "VERSION file missing\n"; sleep 5 };
	$o->{meta_class} = 'desktop' if $VERSION =~ /desktop|discovery/i;
	$o->{meta_class} = 'download' if $VERSION =~ /download/i;
	$o->{meta_class} = 'firewall' if $VERSION =~ /firewall/i;
	$o->{meta_class} = 'server' if $VERSION =~ /server|prosuite/i;
	$o->{distro_type} = 'community' if $VERSION =~ /community/i;
	$o->{distro_type} = 'cooker' if $VERSION =~ /cooker/i;
    }
    $o->{meta_class} eq 'discovery' and $o->{meta_class} = 'desktop';
    log::l("meta_class $o->{meta_class}");
    if ($::oem) {
	$o->{partitioning}{use_existing_root} = 1;
	$o->{compssListLevel} = 4;
	push @auto, 'selectInstallClass', 'doPartitionDisks', 'choosePackages', 'configureTimezone', 'exitInstall';
    }
    if ($::recovery) {
	push @auto, 'selectLanguage', 'selectInstallClass', 'selectMouse', 'selectKeyboard', 'doPartitionDisks', 'formatPartitions', 'miscellaneous', 'choosePackages', 'configureTimezone';
    }

    foreach (@auto) {
	my $s = $o->{steps}{/::(.*)/ ? $1 : $_} or next;
	$s->{auto} = $s->{hidden} = 1;
    }

    my $o_;
    while (1) {
    	$o_ = $::auto_install ?
    	  install_steps_auto_install->new($o) :
    	    $o->{interactive} eq "stdio" ?
    	  install_steps_stdio->new($o) :
    	    $o->{interactive} eq "newt" ?
    	  install_steps_newt->new($o) :
    	    $o->{interactive} eq "gtk" ?
    	  install_steps_gtk->new($o) :
    	    die "unknown install type";
	$o_ and last;

	$o->{interactive} = "newt";
	require install_steps_newt;
    }
    $::o = $o = $o_;

    install_any::remove_unused() if common::usingRamdisk();

    #-the main cycle
    my $clicked = 0;
    MAIN: for ($o->{step} = $o->{steps}{first};; $o->{step} = getNextStep($o)) {
	$o->{steps}{$o->{step}}{entered}++;
	$o->enteringStep($o->{step});
	eval {
	    &{$install2::{$o->{step}}}($clicked || $o->{steps}{$o->{step}}{noauto},
				       $o->{steps}{$o->{step}}{entered},
				       $clicked ? 0 : $o->{steps}{$o->{step}}{auto});
	};
	my $err = $@;
	$o->kill_action;
	$clicked = 0;
	if ($err) {
	    local $_ = $err;
	    $o->kill_action;
	    if (!/^already displayed/) {
		eval { $o->errorInStep($_) };
		$o->{steps}{$o->{step}}{auto} = 0;
		$err = $@;
		$err and next;
	    }
	    $o->{step} = $o->{steps}{$o->{step}}{onError};
	    next MAIN unless $o->{steps}{$o->{step}}{reachable}; #- sanity check: avoid a step not reachable on error.
	    redo MAIN;
	}
	$o->{steps}{$o->{step}}{done} = 1;
	$o->leavingStep($o->{step});

	last if $o->{step} eq 'exitInstall';
    }
    install_any::clean_postinstall_rpms();
    install_any::log_sizes($o);
    install_any::remove_advertising($o);
    install_any::write_fstab($o);
    $o->{modules_conf}->write;
    detect_devices::install_addons($o->{prefix});

    #- save recovery file if needed (ie disk style install).
    $o->{method} eq 'disk' and
      output($o->{prefix} . any::hdInstallPath() . '/install/recovery.cfg', install_any::g_auto_install(1));

    #- mainly for auto_install's
    #- do not use run_program::xxx because it doesn't leave stdin/stdout unchanged
    system("bash", "-c", $o->{postInstallNonRooted}) if $o->{postInstallNonRooted};
    system("chroot", $o->{prefix}, "bash", "-c", $o->{postInstall}) if $o->{postInstall};

    install_any::ejectCdrom();

    #- to ensure linuxconf doesn't cry against those files being in the future
    foreach ('/etc/modules.conf', '/etc/crontab', '/etc/sysconfig/mouse', '/etc/sysconfig/network', '/etc/X11/fs/config') {
	my $now = time() - 24 * 60 * 60;
	utime $now, $now, "$o->{prefix}/$_";
    }
    install_any::killCardServices();

    #- make sure failed upgrade will not hurt too much.
    install_steps::cleanIfFailedUpgrade($o);

    -e "$o->{prefix}/usr/sbin/urpmi.update" or eval { rm_rf("$o->{prefix}/var/lib/urpmi") };

    #- copy latest log files
    eval { cp_af("/tmp/$_", "$o->{prefix}/root/drakx") foreach qw(ddebug.log stage1.log) };

    #- ala pixel? :-) [fpons]
    common::sync(); common::sync();

    log::l("installation complete, leaving");
    log::l("files still open by install2: ", readlink($_)) foreach glob_("/proc/self/fd/*");
    print "\n" x 80;
}

1;